commit bcada3c2c79d5230915a04170b42156b8d17e67d from: Lukas Henkel date: Sun Aug 31 15:07:54 2025 UTC Install basic packages commit - 7c7ad7d3385d344a6f7e50233e88f45057d55864 commit + bcada3c2c79d5230915a04170b42156b8d17e67d blob - a185138e859d5103d30db51e5897b8321ad4a71a blob + 26b44f6ca62b6f780eb0a41a200b4b99f006f9db --- init.el +++ init.el @@ -16,7 +16,9 @@ ("nongnu" . 2) ("melpa-stable" . 1) ("melpa" . 0)) - package-pinned-packages '((sly . "melpa"))) + package-pinned-packages '((sly . "melpa")) + package-selected-packages '(elfeed magit nhexl-mode notmuch paredit paredit-menu sly)) +(package-initialize) ;;;; Completions (setopt tab-always-indent 'complete blob - /dev/null blob + 2e167ef23c812e726d4737c6afe3848126173e33 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/README.md @@ -0,0 +1,409 @@ +# Elfeed Emacs Web Feed Reader + +Elfeed is an extensible web feed reader for Emacs, supporting both +Atom and RSS. It requires Emacs 24.3 and is available for download +from [MELPA](http://melpa.milkbox.net/) or +[el-get](https://github.com/dimitri/el-get). Elfeed was inspired by +[notmuch](http://notmuchmail.org/). + +For a longer overview, + + * [Introducing Elfeed, an Emacs Web Feed Reader](http://nullprogram.com/blog/2013/09/04/). + * [Tips and Tricks](http://nullprogram.com/blog/2013/11/26/) + * [Read your RSS feeds in Emacs with Elfeed +](http://pragmaticemacs.com/emacs/read-your-rss-feeds-in-emacs-with-elfeed/) + * [Scoring Elfeed articles](http://kitchingroup.cheme.cmu.edu/blog/2017/01/05/Scoring-elfeed-articles/) + * [Using Emacs 29](https://www.youtube.com/watch?v=pOFqzK1Ymr4), + [30](https://www.youtube.com/watch?v=tjnK1rkO7RU), + [31](https://www.youtube.com/watch?v=5zuSUbAHH8c) + * [Take Elfeed everywhere: Mobile rss reading Emacs-style (for free/cheap)](http://babbagefiles.blogspot.com/2017/03/take-elfeed-everywhere-mobile-rss.html) + * [Elfeed Rules!](https://noonker.github.io/posts/2020-04-22-elfeed/) ([reddit](https://old.reddit.com/r/emacs/comments/g6oowz/elfeed_rules/)) + * [Elfeed with Tiny Tiny RSS](https://codingquark.com/emacs/2020/04/19/elfeed-protocol-ttrss.html) ([hn](https://news.ycombinator.com/item?id=22915200)) + * [Open Emacs elfeed links in the background](http://xenodium.com/open-emacs-elfeed-links-in-background/) + * [Using Emacs 72](https://cestlaz.github.io/post/using-emacs-72-customizing-elfeed/) + * [Lazy Elfeed](https://karthinks.com/blog/lazy-elfeed/) + * [Using Elfeed to View Videos](https://joshrollinswrites.com/help-desk-head-desk/20200611/) + * [Manage podcasts in Emacs with Elfeed and Bongo](https://protesilaos.com/codelog/2020-09-11-emacs-elfeed-bongo/) + * [... more ...](http://nullprogram.com/tags/elfeed/) + * [... and more ...](http://pragmaticemacs.com/category/elfeed/) + +[![](http://i.imgur.com/kxgF5AH.png)](http://i.imgur.com/kxgF5AH.png) + +The database format is stable and is never expected to change. + +## Prerequisites + +**It is *strongly* recommended you have cURL installed**, either in +your PATH or configured via `elfeed-curl-program-name`. Elfeed will +prefer it to Emacs' own URL-fetching mechanism, `url-retrieve`. It's +also essential for running Elfeed on Windows, where `url-retrieve` is +broken. Updates using cURL are significantly faster than the built-in +method, both for you and the feed hosts. + +If this is giving you problems, fetching with cURL can be disabled by +setting `elfeed-use-curl` to nil. + +## Extensions + +These projects extend Elfeed with additional features: + +* [elfeed-org](https://github.com/remyhonig/elfeed-org) +* [elfeed-goodies](https://github.com/algernon/elfeed-goodies) +* [elfeed-protocol](https://github.com/fasheng/elfeed-protocol) +* [elfeed-score](https://github.com/sp1ff/elfeed-score) +* [Elfeed Android interface](https://github.com/areina/elfeed-cljsrn) + ([Google Play](https://play.google.com/store/apps/details?id=com.elfeedcljsrn)) +* [elfeed-dashboard](https://github.com/Manoj321/elfeed-dashboard) + +## Getting Started + +Elfeed is broken into a multiple source files, so if you manually +install it you will need to add the Elfeed package directory to your +`load-path`. If installed via package.el or el-get, this will be done +automatically. + +It is recommended that you make a global binding for `elfeed`. + +```el +(global-set-key (kbd "C-x w") 'elfeed) +``` + +Running the interactive function `elfeed` will pop up the +`*elfeed-search*` buffer, which will display feed items. + + * g: refresh view of the feed listing + * G: fetch feed updates from the servers + * s: update the search filter (see tags) + * c: clear the search filter + +This buffer will be empty until you add your feeds to the +`elfeed-feeds` list and initiate an update with `M-x elfeed-update` +(or G in the Elfeed buffer). This will populate the Elfeed +database with entries. + +```el +;; Somewhere in your .emacs file +(setq elfeed-feeds + '("http://nullprogram.com/feed/" + "https://planet.emacslife.com/atom.xml")) +``` + +Another option for providing a feed list is with an OPML file. Running +`M-x elfeed-load-opml` will fill `elfeed-feeds` with feeds listed in +an OPML file. When `elfeed-load-opml` is called interactively, it will +automatically save the feedlist to your customization file, so you +will only need to do this once. + +If there are a lot of feeds, the initial update will take noticeably +longer than normal operation because of the large amount of +information being written the database. Future updates will only need +to write new or changed data. If updating feeds slows down Emacs too +much for you, reduce the number of concurrent fetches via +`elfeed-set-max-connections`. + +If you're getting many "Queue timeout exceeded" errors, increase the +fetch timeout via `elfeed-set-timeout`. + +~~~el +(setf url-queue-timeout 30) +~~~ + +From the search buffer there are a number of ways to interact with +entries. Entries are selected by placing the point over an entry. +Multiple entries are selected at once by using an active region. + + * RET: view selected entry in a buffer + * b: open selected entries in your browser (`browse-url`) + * y: copy selected entries URL to the clipboard + * r: mark selected entries as read + * u: mark selected entries as unread + * +: add a specific tag to selected entries + * -: remove a specific tag from selected entries + +## Tags + +Elfeed maintains a list of arbitrary tags -- symbols attached to an +entry. The tag `unread` is treated specially by default, with unread +entries appearing in bold. + +### Autotagging + +Tags can automatically be applied to entries discovered in specific +feeds through extra syntax in `elfeed-feeds`. Normally this is a list +of strings, but an item can also be a list, providing set of +"autotags" for a feed's entries. + +```el +(setq elfeed-feeds + '(("http://nullprogram.com/feed/" blog emacs) + "http://www.50ply.com/atom.xml" ; no autotagging + ("http://nedroid.com/feed/" webcomic))) +``` + +### Filter Syntax + +To make tags useful, the Elfeed entry listing buffer can be filtered +by tags. Use `elfeed-search-set-filter` (or s) to update +the filter. Use `elfeed-search-clear-filter` to restore the default. + +Any component of the search string beginning with a `+` or +a `-` is treated like a tag. `+` means the tag is required, `-` means +the tag must not be present. + +A component beginning with a `@` indicates an age or a date range. An +age is a relative time expression or an absolute date expression. +Entries older than this age are filtered out. The age description +accepts plain English, but cannot have spaces, so use dashes. For +example, `"@2-years-old"`, `"@3-days-ago"` or `"@2019-06-24"`. A date +range are two ages seperated by a `--`, e.g. +`"@2019-06-20--2019-06-24"` or `"@5-days-ago--1-day-ago"`. The entry +must be newer than the first expression but older than the second. The +database is date-oriented, so **filters that include an age +restriction are significantly more efficient.** + +A component beginning with a `!` is treated as an "inverse" regular +expression. This means that any entry matching this regular expression +will be filtered out. The regular expression begins *after* the `!` +character. You can read this as "entry not matching `foo`". + +A component beginning with a `#` limits the total number of entries +displayed to the number immediately following the symbol. For example, +to limit the display to 20 entries: `#20`. + +A component beginning with a `=` is a regular expression matching the +entry's feed (title or URL). Only entries belonging to a feed that +matches at least one of the `=` expressions will be shown. + +A component beginning with a `~` is a regular expression matching the +entry's feed (title or URL). Only entries belonging to a feed that +matches none of the `~` expressions will be shown. + +All other components are treated as a regular expression, and only +entries matching it (title or URL) will be shown. + +Here are some example filters. + + * `@6-months-ago +unread` + +Only show unread entries of the last six months. This is the default filter. + + * `linu[xs] @1-year-old` + +Only show entries about Linux or Linus from the last year. + + * `-unread +youtube #10` + +Only show the most recent 10 previously-read entries tagged as +`youtube`. + + * `+unread !x?emacs` + +Only show unread entries not having `emacs` or `xemacs` in the title +or link. + +* `+emacs =http://example.org/feed/` + +Only show entries tagged as `emacs` from a specific feed. + +#### Default Search Filter + +You can set your default search filter by changing the default value +of `elfeed-search-filter`. It only changes buffer-locally when you're +adjusting the filter within Elfeed. For example, some users prefer to +have a space on the end for easier quick searching. + + (setq-default elfeed-search-filter "@1-week-ago +unread ") + +### Tag Hooks + +The last example assumes you've tagged posts with `youtube`. You +probably want to do this sort of thing automatically, either through +the "autotags" feature mentioned above, or with the +`elfeed-new-entry-hook`. Functions in this hook are called with new +entries, allowing them to be manipulated, such as adding tags. + +```el +;; Mark all YouTube entries +(add-hook 'elfeed-new-entry-hook + (elfeed-make-tagger :feed-url "youtube\\.com" + :add '(video youtube))) +``` + +Avoiding tagging old entries as `unread`: + +```el +;; Entries older than 2 weeks are marked as read +(add-hook 'elfeed-new-entry-hook + (elfeed-make-tagger :before "2 weeks ago" + :remove 'unread)) +``` + +Or building your own subset feeds: + +```el +(add-hook 'elfeed-new-entry-hook + (elfeed-make-tagger :feed-url "example\\.com" + :entry-title '(not "something interesting") + :add 'junk + :remove 'unread)) +``` + +Use `M-x elfeed-apply-hooks-now` to apply `elfeed-new-entry-hook` to +all existing entries. Otherwise hooks will only apply to new entries +on discovery. + +### Custom Tag Faces + +By default, entries marked `unread` will have bolded titles in the +`*elfeed-search*` listing. You can customize how tags affect an +entry's appearance by customizing `elfeed-search-face-alist`. For +example, this configuration makes entries tagged `important` stand out +in red. + +~~~el +(defface important-elfeed-entry + '((t :foreground "#f77")) + "Marks an important Elfeed entry.") + +(push '(important important-elfeed-entry) + elfeed-search-face-alist) +~~~ + +All faces from all tags will be applied to the entry title. The faces +will be ordered as they appear in `elfeed-search-face-alist`. + +## Bookmarks + +Filters can be saved and restored using Emacs' built-in [bookmarks +feature][bm]. While in the search buffer, use `M-x bookmark-set` to +save the current filter, and `M-x bookmark-jump` to restore a saved +filter. Emacs automatically persists bookmarks across sessions. + +[bm]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Bookmarks.html + +## Metadata Plist + +All feed and entry objects have plist where you can store your own +arbitrary, [readable values][rd]. These values are automatically +persisted in the database. This metadata is accessed using the +polymorphic `elfeed-meta` function. It's setf-able. + +~~~el +(setf (elfeed-meta entry :rating) 4) +(elfeed-meta entry :rating) +;; => 4 + +(setf (elfeed-meta feed :title) "My Better Title") +~~~ + +Elfeed itself adds some entries to this plist, some for your use, some +for its own use. Here are the properties that Elfeed uses: + +* `:authors` : A list of author plists (`:name`, `:uri`, `:email`). +* `:canonical-url` : The final URL for the feed after all redirects. +* `:categories` : The feed-supplied categories for this entry. +* `:etag` : HTTP Etag header, for conditional GETs. +* `:failures` : Number of times this feed has failed to update. +* `:last-modified` : HTTP Last-Modified header, for conditional GETs. +* `:title` : Overrides the feed-supplied title for display purposes, + both for feeds and entries. See also `elfeed-search-set-feed-title` + and `elfeed-search-set-entry-title`. + +This list will grow in time, so you might consider namespacing your +own properties to avoid collisions (e.g. `:xyz/rating`), or simply not +using keywords as keys. Elfeed will always use keywords without a +slash. + +[rd]: http://nullprogram.com/blog/2013/12/30/ + +## Hooks + +A number of hooks are available to customize the behavior of Elfeed at +key points without resorting to advice. + +* `elfeed-new-entry-hook` : Called each time a new entry it added to + the database, allowing for automating tagging and such. +* `elfeed-new-entry-parse-hook` : Called with each new entry and the + full XML structure from which it was parsed, allowing for additional + information to be drawn from the original feed XML. +* `elfeed-http-error-hooks` : Allows for special behavior when HTTP + errors occur, beyond simply logging the error to `*elfeed-log*` . +* `elfeed-parse-error-hooks` : Allows for special behavior when feed + parsing fails, beyond logging. +* `elfeed-db-update-hook` : Called any time the database has had a + major modification. + +## Viewing Entries + +Entries are viewed locally in Emacs by typing `RET` while over an +entry in the search listing. The content will be displayed in a +separate buffer using `elfeed-show-mode`, rendered using Emacs' +built-in shr package. This requires an Emacs compiled with `libxml2` +bindings, which provides the necessary HTML parser. + +Sometimes displaying images can slow down or even crash Emacs. Set +`shr-inhibit-images` to disable images if this is a problem. + +## Web Interface + +Elfeed includes a demonstration/toy web interface for remote network +access. It's a single-page web application that follows the database +live as new entries arrive. It's packaged separately as `elfeed-web`. +To fire it up, run `M-x elfeed-web-start` and visit +http://localhost:8080/elfeed/ (check your `httpd-port`) with a +browser. See the `elfeed-web.el` header for endpoint documentation if +you'd like to access the Elfeed database through the web API. + +It's rough and unfinished -- no keyboard shortcuts, read-only, no +authentication, and a narrow entry viewer. This is basically Elfeed's +"mobile" interface. Patches welcome. + +## Platform Support + +Summary: Install cURL and most problems disappear for all platforms. + +I personally only use Elfeed on Linux, but it's occasionally tested on +Windows. Unfortunately the Windows port of Emacs is a bit too unstable +for parallel feed downloads with `url-retrieve`, not to mention the +[tiny, hard-coded, 512 open descriptor limitation][files], so it +limits itself to one feed at a time on this platform. + +[files]: http://msdn.microsoft.com/en-us/library/kdfaxaay%28vs.71%29.aspx + +If you fetch HTTPS feeds without cURL on *any* platform, it's +essential that Emacs is built with the `--with-gnutls` option. +Otherwise Emacs runs gnutls in an inferior process, which rarely works +well. + +## Database Management + +The database should keep itself under control without any manual +intervention, but steps can be taken to minimize the database size if +desired. The simplest option is to run the `elfeed-db-compact` +command, which will pack the loose-file content database into a single +compressed file. This function works well in `kill-emacs-hook`. + +Going further, a function could be added to `elfeed-new-entry-hook` to +strip unwanted/unneeded content from select entries before being +stored in the database. For example, for YouTube videos only the entry +link is of interest and the regularly-changing entry content could be +tossed to save time and storage. + +## Status and Roadmap + +Elfeed is to the point where it can serve 100% of my own web feed +needs. My personal selection of about 150 feeds has been acting as my +test case as I optimize and add features. + +Some things I still might want to add: + +* Database synchronization between computers +* Parallel feed fetching via separate Emacs subprocesses + +## Motivation + +As far as I know, outside of Elfeed there does not exist an +extensible, text-file configured, power-user web feed client that can +handle a reasonable number of feeds. The existing clients I've tried +are missing some important capability that limits its usefulness to +me. blob - /dev/null blob + 1777cfc7d7205bc5609d183a4a2ac7ff15cac3e5 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-autoloads.el @@ -0,0 +1,114 @@ +;;; elfeed-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from elfeed.el + +(autoload 'elfeed-update "elfeed" "\ +Update all the feeds in `elfeed-feeds'." t) +(autoload 'elfeed "elfeed" "\ +Enter elfeed." t) +(autoload 'elfeed-load-opml "elfeed" "\ +Load feeds from an OPML file into `elfeed-feeds'. +When called interactively, the changes to `elfeed-feeds' are +saved to your customization file. + +(fn FILE)" t) +(autoload 'elfeed-export-opml "elfeed" "\ +Export the current feed listing to OPML-formatted FILE. + +(fn FILE)" t) +(register-definition-prefixes "elfeed" '("elfeed-")) + + +;;; Generated autoloads from elfeed-csv.el + +(register-definition-prefixes "elfeed-csv" '("elfeed-csv-")) + + +;;; Generated autoloads from elfeed-curl.el + +(register-definition-prefixes "elfeed-curl" '("elfeed-curl-")) + + +;;; Generated autoloads from elfeed-db.el + +(register-definition-prefixes "elfeed-db" '("elfeed-" "with-elfeed-db-visit")) + + +;;; Generated autoloads from elfeed-lib.el + +(register-definition-prefixes "elfeed-lib" '("elfeed-")) + + +;;; Generated autoloads from elfeed-link.el + +(autoload 'elfeed-link-store-link "elfeed-link" "\ +Store a link to an elfeed search or entry buffer. + +When storing a link to an entry, automatically extract all the +entry metadata. These can be used in the capture templates as +%:elfeed-entry-. See `elfeed-entry--create' for the list +of available props.") +(autoload 'elfeed-link-open "elfeed-link" "\ +Jump to an elfeed entry or search. + +Depending on what FILTER-OR-ID looks like, we jump to either +search buffer or show a concrete entry. + +(fn FILTER-OR-ID)") +(eval-after-load 'org `(funcall ',(lambda nil (if (version< (org-version) "9.0") (with-no-warnings (org-add-link-type "elfeed" #'elfeed-link-open) (add-hook 'org-store-link-functions #'elfeed-link-store-link)) (with-no-warnings (org-link-set-parameters "elfeed" :follow #'elfeed-link-open :store #'elfeed-link-store-link)))))) + + +;;; Generated autoloads from elfeed-log.el + +(register-definition-prefixes "elfeed-log" '("elfeed-log")) + + +;;; Generated autoloads from elfeed-search.el + +(autoload 'elfeed-search-bookmark-handler "elfeed-search" "\ +Jump to an elfeed-search bookmarked location. + +(fn RECORD)") +(autoload 'elfeed-search-desktop-restore "elfeed-search" "\ +Restore the state of an elfeed-search buffer on desktop restore. + +(fn FILE-NAME BUFFER-NAME SEARCH-FILTER)") +(add-to-list 'desktop-buffer-mode-handlers '(elfeed-search-mode . elfeed-search-desktop-restore)) +(register-definition-prefixes "elfeed-search" '("elfeed-s")) + + +;;; Generated autoloads from elfeed-show.el + +(autoload 'elfeed-show-bookmark-handler "elfeed-show" "\ +Show the bookmarked entry saved in the `RECORD'. + +(fn RECORD)") +(register-definition-prefixes "elfeed-show" '("elfeed-")) + + +;;; Generated autoloads from xml-query.el + +(register-definition-prefixes "xml-query" '("xml-query")) + +;;; End of scraped data + +(provide 'elfeed-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; elfeed-autoloads.el ends here blob - /dev/null blob + ae1f1457e26aef01e2f7cfcad9a4b3838850edbd (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-csv.el @@ -0,0 +1,176 @@ +;;; elfeed-csv.el --- export database to CSV files -*- lexical-binding: t; -*- + +;;; Commentary: + +;; The `elfeed-csv-export' docstring has a SQL schema recommendation. +;; Given these schemas, these CSV files are trivially imported into a +;; SQLite database using the sqlite3 command line program: + +;; sqlite> .mode csv +;; sqlite> .import feeds.csv feeds +;; sqlite> .import entries.csv entries +;; sqlite> .import tags.csv tags + +;; Note: nil values won't be imported as NULL, but as empty strings. + +;; Here are a few interesting queries to make on your own data: + +;; For each tag in your database, compute a histogram of posts with +;; 1-hour bins across the the day (0-23), in your local timezone. + +;; SELECT tag, +;; cast(strftime('%H', date, 'unixepoch', 'localtime') AS INT) AS hour, +;; count(id) AS count +;; FROM entries +;; JOIN tags ON tags.entry = entries.id AND tags.feed = entries.feed +;; GROUP BY tag, hour; + +;; Like above, but per week-day (0-6). + +;; SELECT tag, +;; cast(strftime('%w', date, 'unixepoch', 'localtime') AS INT) AS day, +;; count(id) AS count +;; FROM entries +;; JOIN tags ON tags.entry = entries.id AND tags.feed = entries.feed +;; GROUP BY tag, day; + +;; For each feed, compute the number of entries and last entry date. + +;; SELECT feeds.title AS title, +;; count(url) AS entry_count, +;; datetime(max(date), 'unixepoch') AS last_entry_date +;; FROM feeds +;; JOIN entries ON feeds.url = entries.feed +;; GROUP BY url +;; ORDER BY max(date) DESC; + +;; Compute a histogram of entry title lengths. + +;; SELECT length(title) AS length, +;; count(*) AS count +;; FROM entries +;; GROUP BY length +;; ORDER BY length; + +;; Again, but this time group by tag. + +;; SELECT tag, +;; length(title) AS length, +;; count(*) AS count +;; FROM entries +;; JOIN tags ON tags.entry = entries.id AND tags.feed = entries.feed +;; GROUP BY tag, length +;; ORDER BY length; + +;; What's the relationship between title length and time of day of an +;; entry? (Scatter plot this result.) + +;; SELECT (date % (24*60*60)) / (24*60*60) AS day_time, +;; length(title) AS length +;; FROM entries +;; JOIN tags ON tags.entry = entries.id AND tags.feed = entries.feed; + +;;; Code: + +(require 'cl-lib) +(require 'elfeed-db) + +(defvar elfeed-csv-nil "" + "The string representation to use for nil. +Consider let-binding this around your `elfeed-csv-quote' call.") + +(defun elfeed-csv-quote (sexp) + "Return CSV string representation of SEXP." + (cond ((null sexp) + elfeed-csv-nil) + ((not (stringp sexp)) + (elfeed-csv-quote (prin1-to-string sexp))) + ((string-match-p "[\"\n,]" sexp) + (concat "\"" (replace-regexp-in-string "\"" "\"\"" sexp) "\"")) + (sexp))) + +(defun elfeed-csv-insert (seq) + "Insert a row of CSV data to the current buffer." + (cl-loop for value being the elements of seq + for column upfrom 0 + when (> column 0) + do (insert ",") + do (insert (elfeed-csv-quote value)) + finally (newline))) + +(cl-defun elfeed-csv-export (feeds-file entries-file tags-file &key headers-p) + "Create separate CSV files for feeds, entries, and tags. + +These CSV files are intended for an analysis of an Elfeed +database. They are suitable for importing as tables into a +relational database such as SQLite. Here's the recommended SQL +schema, reflecting the structure of the data. + +CREATE TABLE feeds ( + url TEXT PRIMARY KEY, + title TEXT, + canonical_url TEXT, + author TEXT +); + +CREATE TABLE entries ( + id TEXT NOT NULL, + feed TEXT NOT NULL REFERENCES feeds (url), + title TEXT, + link TEXT NOT NULL, + date REAL NOT NULL, + PRIMARY KEY (id, feed) +); + +CREATE TABLE tags ( + entry TEXT NOT NULL, + feed TEXT NOT NULL, + tag TEXT NOT NULL, + FOREIGN KEY (entry, feed) REFERENCES entries (id, feed) +);" + (let ((feeds-buffer (generate-new-buffer " *csv-feeds*")) + (entries-buffer (generate-new-buffer " *csv-entries*")) + (tags-buffer (generate-new-buffer " *csv-tags*")) + (seen (make-hash-table :test 'eq))) + ;; Write headers + (when headers-p + (with-current-buffer feeds-buffer + (elfeed-csv-insert [url title canonical-url author])) + (with-current-buffer entries-buffer + (elfeed-csv-insert [id feed title link date])) + (with-current-buffer tags-buffer + (elfeed-csv-insert [entry feed tag]))) + ;; Write data + (with-elfeed-db-visit (entry feed) + (unless (gethash feed seen) + (setf (gethash feed seen) t) + (let ((url (elfeed-feed-url feed)) + (title (elfeed-feed-title feed)) + (canonical-url (elfeed-meta feed :canonical-url)) + (author (elfeed-feed-author feed))) + (with-current-buffer feeds-buffer + (elfeed-csv-insert (list url title canonical-url author))))) + (let ((id (cdr (elfeed-entry-id entry))) + (feed-id (elfeed-entry-feed-id entry)) + (title (elfeed-entry-title entry)) + (link (elfeed-entry-link entry)) + (date (elfeed-entry-date entry))) + (with-current-buffer entries-buffer + (elfeed-csv-insert (list id feed-id title link date))) + (with-current-buffer tags-buffer + (dolist (tag (elfeed-entry-tags entry)) + (elfeed-csv-insert (list id feed-id tag)))))) + ;; Write files + (with-current-buffer tags-buffer + (write-region nil nil tags-file nil 0) + (kill-buffer)) + (with-current-buffer entries-buffer + (write-region nil nil entries-file nil 0) + (kill-buffer)) + (with-current-buffer feeds-buffer + (write-region nil nil feeds-file nil 0) + (kill-buffer)))) + +(provide 'elfeed-csv) + +;;; elfeed-csv.el ends here blob - /dev/null blob + c801696066385f7c0cf11a2c1e6a7104cd759246 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-curl.el @@ -0,0 +1,532 @@ +;;; elfeed-curl.el --- curl backend for Elfeed -*- lexical-binding: t; -*- + +;;; Comments: + +;; An alternative to `url-retrieve' and `url-queue' that fetches URLs +;; using the curl command line program. + +;; The API is three functions: + +;; * `elfeed-curl-retrieve' +;; * `elfeed-curl-retrieve-synchronously' +;; * `elfeed-curl-enqueue' + +;; And has four buffer-local variables for use in callbacks: + +;; * `elfeed-curl-headers' +;; * `elfeed-curl-status-code' +;; * `elfeed-curl-error-message' +;; * `elfeed-curl-location' + +;; The buffer delivered to callbacks may contain multiple requests. It +;; will be narrowed to the specific content for the current request. +;; It's vitally important that callbacks do not kill the buffer +;; because it may be needed for other callbacks. It also means the +;; buffer won't necessarily be around when the callback returns. +;; Callbacks should also avoid editing the buffer, though this +;; generally shouldn't impact other requests. + +;; Sometimes Elfeed asks curl to retrieve multiple requests and +;; deliver them concatenated. Due to the possibility of HTTP/1.0 being +;; involved — and other ambiguous-length protocols — there's no +;; perfectly unambiguous way to split the output. To work around this, +;; I use curl's --write-out to insert a randomly-generated token after +;; each request. It's highly unlikely (1 in ~1e38) that this token +;; will appear in content, so I can use it to identify the end of each +;; request. + +;;; Code: + +(require 'url) +(require 'cl-lib) +(require 'elfeed-lib) +(require 'elfeed-log) + +(defcustom elfeed-curl-program-name "curl" + "Name/path by which to invoke the curl program." + :group 'elfeed + :type 'string) + +(defcustom elfeed-curl-max-connections 16 + "Maximum number of concurrent fetches." + :group 'elfeed + :type 'integer) + +(defcustom elfeed-curl-timeout 30 + "Maximum number of seconds a fetch is allowed to take once started." + :group 'elfeed + :type 'integer) + +(defcustom elfeed-curl-extra-arguments () + "A list of additional arguments to pass to cURL. +These extra arguments are appended after Elfeed's own arguments, +and care must be taken to not interfere with Elfeed's needs. The +guideline is to avoid arguments that change anything about cURL's +output format." + :group 'elfeed + :type '(repeat string)) + +(defvar elfeed-curl-queue () + "List of pending curl requests.") + +(defvar elfeed-curl-queue-active 0 + "Number of concurrent requests currently active.") + +(defvar-local elfeed-curl-headers nil + "Alist of HTTP response headers.") + +(defvar-local elfeed-curl-status-code nil + "Numeric HTTP response code, nil for non-HTTP protocols.") + +(defvar-local elfeed-curl-error-message nil + "Human-friendly message describing the error.") + +(defvar-local elfeed-curl-location nil + "Actual URL fetched (after any redirects).") + +(defvar-local elfeed-curl--regions () + "List of markers bounding separate requests.") + +(defvar-local elfeed-curl--requests () + "List of URL / callback pairs for the current buffer.") + +(defvar-local elfeed-curl--token nil + "Unique token that splits requests.") + +(defvar-local elfeed-curl--refcount nil + "Number of callbacks waiting on the current buffer.") + +(defvar elfeed-curl--error-codes + '((1 . "Unsupported protocol.") + (2 . "Failed to initialize.") + (3 . "URL malformed. The syntax was not correct.") + (4 . "A feature or option that was needed to perform the desired request was not enabled or was explicitly disabled at build-time.") + (5 . "Couldn't resolve proxy. The given proxy host could not be resolved.") + (6 . "Couldn't resolve host. The given remote host was not resolved.") + (7 . "Failed to connect to host.") + (8 . "FTP weird server reply. The server sent data curl couldn't parse.") + (9 . "FTP access denied.") + (11 . "FTP weird PASS reply.") + (13 . "FTP weird PASV reply.") + (14 . "FTP weird 227 format.") + (15 . "FTP can't get host.") + (16 . "A problem was detected in the HTTP2 framing layer.") + (17 . "FTP couldn't set binary.") + (18 . "Partial file. Only a part of the file was transferred.") + (19 . "FTP couldn't download/access the given file, the RETR (or similar) command failed.") + (21 . "FTP quote error. A quote command returned error from the server.") + (22 . "HTTP page not retrieved.") + (23 . "Write error.") + (25 . "FTP couldn't STOR file.") + (26 . "Read error. Various reading problems.") + (27 . "Out of memory. A memory allocation request failed.") + (28 . "Operation timeout.") + (30 . "FTP PORT failed.") + (31 . "FTP couldn't use REST.") + (33 . "HTTP range error. The range \"command\" didn't work.") + (34 . "HTTP post error. Internal post-request generation error.") + (35 . "SSL connect error. The SSL handshaking failed.") + (36 . "FTP bad download resume.") + (37 . "FILE couldn't read file.") + (38 . "LDAP bind operation failed.") + (39 . "LDAP search failed.") + (41 . "Function not found. A required LDAP function was not found.") + (42 . "Aborted by callback.") + (43 . "Internal error. A function was called with a bad parameter.") + (45 . "Interface error. A specified outgoing interface could not be used.") + (47 . "Too many redirects.") + (48 . "Unknown option specified to libcurl.") + (49 . "Malformed telnet option.") + (51 . "The peer's SSL certificate or SSH MD5 fingerprint was not OK.") + (52 . "The server didn't reply anything, which here is considered an error.") + (53 . "SSL crypto engine not found.") + (54 . "Cannot set SSL crypto engine as default.") + (55 . "Failed sending network data.") + (56 . "Failure in receiving network data.") + (58 . "Problem with the local certificate.") + (59 . "Couldn't use specified SSL cipher.") + (60 . "Peer certificate cannot be authenticated with known CA certificates.") + (61 . "Unrecognized transfer encoding.") + (62 . "Invalid LDAP URL.") + (63 . "Maximum file size exceeded.") + (64 . "Requested FTP SSL level failed.") + (65 . "Sending the data requires a rewind that failed.") + (66 . "Failed to initialise SSL Engine.") + (67 . "The user name, password, or similar was not accepted and curl failed to log in.") + (68 . "File not found on TFTP server.") + (69 . "Permission problem on TFTP server.") + (70 . "Out of disk space on TFTP server.") + (71 . "Illegal TFTP operation.") + (72 . "Unknown TFTP transfer ID.") + (73 . "File already exists (TFTP).") + (74 . "No such user (TFTP).") + (75 . "Character conversion failed.") + (76 . "Character conversion functions required.") + (77 . "Problem with reading the SSL CA cert (path? access rights?).") + (78 . "The resource referenced in the URL does not exist.") + (79 . "An unspecified error occurred during the SSH session.") + (80 . "Failed to shut down the SSL connection.") + (82 . "Could not load CRL file, missing or wrong format (added in 7.19.0).") + (83 . "Issuer check failed (added in 7.19.0).") + (84 . "The FTP PRET command failed") + (85 . "RTSP: mismatch of CSeq numbers") + (86 . "RTSP: mismatch of Session Identifiers") + (87 . "unable to parse FTP file list") + (88 . "FTP chunk callback reported error") + (89 . "No connection available, the session will be queued") + (90 . "SSL public key does not matched pinned public key"))) + +(defvar elfeed-curl--capabilities-cache + (make-hash-table :test 'eq :weakness 'key) + "Used to avoid invoking curl more than once for version info.") + +(defun elfeed-curl-get-capabilities () + "Return capabilities plist for the curl at `elfeed-curl-program-name'. +:version -- cURL's version string +:compression -- non-nil if --compressed is supported +:protocols -- symbol list of supported protocols +:features -- string list of supported features" + (let* ((cache elfeed-curl--capabilities-cache) + (cache-value (gethash elfeed-curl-program-name cache))) + (if cache-value + cache-value + (with-temp-buffer + (call-process elfeed-curl-program-name nil t nil "--version") + (let ((version + (progn + (goto-char (point-min)) + (when (re-search-forward "[.0-9]+" nil t) + (match-string 0)))) + (protocols + (progn + (goto-char (point-min)) + (when (re-search-forward "^Protocols: \\(.*\\)$" nil t) + (mapcar #'intern (split-string (match-string 1)))))) + (features + (progn + (goto-char (point-min)) + (when (re-search-forward "^Features: \\(.*\\)$") + (split-string (match-string 1)))))) + (setf (gethash elfeed-curl-program-name cache) + (list :version version + :compression (not (null (member "libz" features))) + :protocols protocols + :features features))))))) + +(defun elfeed-curl-get-version () + "Return the version of curl for `elfeed-curl-program-name'." + (plist-get (elfeed-curl-get-capabilities) :version)) +(make-obsolete 'elfeed-curl-get-version 'elfeed-curl-get-capabilities "3.0.1") + +(defun elfeed-curl--token () + "Return a unique, random string that prints as a symbol without escapes. +This token is used to split requests. The % is excluded since +it's special to --write-out." + (let* ((token (make-string 22 ?=)) + (set "!$&*+-/0123456789:<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_\ +abcdefghijklmnopqrstuvwxyz|~")) + (prog1 token ; workaround bug#16206 + (dotimes (i (- (length token) 2)) + (setf (aref token (1+ i)) (aref set (cl-random (length set)))))))) + +(defun elfeed-curl--parse-write-out () + "Parse curl's write-out (-w) messages into `elfeed-curl--regions'." + (widen) + (goto-char (point-max)) + (setf elfeed-curl--regions ()) + (while (> (point) (point-min)) + (search-backward elfeed-curl--token) + (goto-char (1- (point))) + (let ((end (point))) + (cl-destructuring-bind (_ . header) (read (current-buffer)) + (goto-char end) + ;; Find next sentinel token + (if (search-backward elfeed-curl--token nil t) + (search-forward ")" nil t) + (goto-char (point-min))) + (let* ((header-start (point)) + (header-end (+ (point) header)) + (content-start (+ (point) header)) + (content-end end) + (regions (list header-start header-end + content-start content-end)) + (markers (cl-loop for p in regions + for marker = (make-marker) + collect (set-marker marker p)))) + (push markers elfeed-curl--regions)))))) + +(defun elfeed-curl--narrow (kind n) + "Narrow to Nth region of KIND (:header, :content)." + (let ((region (nth n elfeed-curl--regions))) + (cl-destructuring-bind (h-start h-end c-start c-end) region + (cl-ecase kind + (:header (narrow-to-region h-start h-end)) + (:content (narrow-to-region c-start c-end)))))) + +(defun elfeed-curl--parse-http-headers () + "Parse the current HTTP response headers into buffer-locals. +Sets `elfeed-curl-headers'and `elfeed-curl-status-code'. +Use `elfeed-curl--narrow' to select a header." + (when (> (- (point-max) (point-min)) 0) + (goto-char (point-max)) + (re-search-backward "HTTP/[.0-9]+ +\\([0-9]+\\)") + (setf elfeed-curl-status-code (string-to-number (match-string 1))) + (cl-loop initially (goto-char (point-max)) + while (re-search-backward "^\\([^:]+\\): +\\([^\r\n]+\\)" nil t) + for key = (downcase (match-string 1)) + for value = (match-string 2) + collect (cons key value) into headers + finally (setf elfeed-curl-headers headers)))) + +(defun elfeed-curl--decode () + "Try to decode the buffer based on the headers." + (let ((content-type (cdr (assoc "Content-Type" elfeed-curl-headers)))) + (if (and content-type (string-match "charset=\\(.+\\)" content-type)) + (decode-coding-region (point-min) (point-max) + (coding-system-from-name + (match-string 1 content-type))) + (decode-coding-region (point-min) (point-max) 'utf-8)))) + +(defun elfeed-curl--final-location (location headers) + "Given start LOCATION and HEADERS, find the final location." + (cl-loop for (key . value) in headers + when (equal key "location") + do (setf location (elfeed-update-location location value)) + finally return location)) + +(defun elfeed-curl--args (url token &optional headers method data) + "Build an argument list for curl for URL. +URL can be a string or a list of URL strings." + (let* ((args ()) + (capabilities (elfeed-curl-get-capabilities))) + (push "--disable" args) + (when (plist-get capabilities :compression) + (push "--compressed" args)) + (push "--silent" args) + (push "--location" args) + (push (format "-w(%s . %%{size_header})" token) args) + (push (format "-m%s" elfeed-curl-timeout) args) + (push "-D-" args) + (dolist (header headers) + (cl-destructuring-bind (key . value) header + (push (format "-H%s: %s" key value) args))) + (when method (push (format "-X%s" method) args)) + (when data (push (format "-d%s" data) args)) + (setf args (nconc (reverse elfeed-curl-extra-arguments) args)) + (if (listp url) + (nconc (nreverse args) url) + (nreverse (cons url args))))) + +(defun elfeed-curl--prepare-response (url n protocol) + "Prepare response N for delivery to user." + (elfeed-curl--narrow :header n) + (when (eq protocol 'http) + (elfeed-curl--parse-http-headers)) + (setf elfeed-curl-location + (elfeed-curl--final-location url elfeed-curl-headers)) + (elfeed-curl--narrow :content n) + (elfeed-curl--decode) + (current-buffer)) + +(cl-defun elfeed-curl-retrieve-synchronously (url &key headers method data) + "Retrieve the contents for URL and return a new buffer with them. + +HEADERS is an alist of additional headers to add to the HTTP request. +METHOD is the HTTP method to use. +DATA is the content to include in the request." + (with-current-buffer (generate-new-buffer " *curl*") + (setf elfeed-curl--token (elfeed-curl--token)) + (let ((args (elfeed-curl--args url elfeed-curl--token headers method data)) + (coding-system-for-read 'binary)) + (apply #'call-process elfeed-curl-program-name nil t nil args)) + (elfeed-curl--parse-write-out) + (elfeed-curl--prepare-response url 0 (elfeed-curl--protocol-type url)))) + +(defun elfeed-curl--protocol-type (url) + (let ((scheme (intern (or (url-type (url-generic-parse-url url)) "nil")))) + (cl-case scheme + ((https nil) 'http) + (otherwise scheme)))) + +(defun elfeed-curl--call-callback (buffer n url cb) + "Prepare the buffer for callback N and call it." + (let ((result nil) + (protocol (elfeed-curl--protocol-type url))) + (with-current-buffer buffer + (setf elfeed-curl-error-message "unable to parse curl response") + (unwind-protect + (progn + (elfeed-curl--prepare-response url n protocol) + (cond ((eq protocol 'file) + ;; No status code is returned by curl for file:// urls + (setf result t + elfeed-curl-error-message nil)) + ((eq protocol 'gopher) + (setf result t + elfeed-curl-error-message nil + elfeed-curl-status-code nil)) + ((and (>= elfeed-curl-status-code 400) + (<= elfeed-curl-status-code 599)) + (setf elfeed-curl-error-message + (format "HTTP %d" elfeed-curl-status-code))) + (t + (setf result t + elfeed-curl-error-message nil))) + ;; Always call callback + (unwind-protect + (funcall cb result) + ;; Always clean up + (when (zerop (cl-decf elfeed-curl--refcount)) + (kill-buffer)))))))) + +(defun elfeed-curl--fail-callback (buffer cb) + "Inform the callback the request failed." + (with-current-buffer buffer + (unwind-protect + (funcall cb nil) + (when (zerop (cl-decf elfeed-curl--refcount)) + (kill-buffer))))) + +(defun elfeed-curl--sentinel (process status) + "Manage the end of a curl process' life." + (let ((buffer (process-buffer process))) + (with-current-buffer buffer + ;; Fire off callbacks in separate interpreter turns so they can + ;; each fail in isolation from each other. + (if (equal status "finished\n") + (cl-loop with handler = #'elfeed-curl--call-callback + initially do (elfeed-curl--parse-write-out) + for (url . cb) in elfeed-curl--requests + for n upfrom 0 + do (run-at-time 0 nil handler buffer n url cb)) + (if (string-match "exited abnormally with code \\([0-9]+\\)" status) + (let* ((code (string-to-number (match-string 1 status))) + (message (cdr (assoc code elfeed-curl--error-codes)))) + (setf elfeed-curl-error-message + (format "(%d) %s" code + (or message "Unknown curl error!")))) + (setf elfeed-curl-error-message status)) + (cl-loop with handler = #'elfeed-curl--fail-callback + for (_ . cb) in elfeed-curl--requests + do (run-at-time 0 nil handler buffer cb)))))) + +(cl-defun elfeed-curl-retrieve (url cb &key headers method data) + "Retrieve URL contents asynchronously, calling CB with one status argument. + +The callback must *not* kill the buffer! + +The destination buffer is set at the current buffer for the +callback. + +HEADERS is an alist of additional headers to add to HTTP requests. +METHOD is the HTTP method to use. +DATA is the content to include in the request. + +URL can be a list of URLs, which will fetch them all in the same +curl process. In this case, CB can also be either a list of the +same length, or just a single function to be called once for each +URL in the list. Headers will be common to all requests. A TCP or +DNS failure in one will cause all to fail, but 4xx and 5xx +results will not." + (with-current-buffer (generate-new-buffer " *curl*") + (setf elfeed-curl--token (elfeed-curl--token)) + (let* ((coding-system-for-read 'binary) + (process-connection-type nil) + (args (elfeed-curl--args url elfeed-curl--token headers method data)) + (process (apply #'start-process "elfeed-curl" (current-buffer) + elfeed-curl-program-name args))) + (prog1 process + (if (listp url) + (progn + (when (functionp cb) + (setf cb (make-list (length url) cb))) + (setf elfeed-curl--requests (cl-mapcar #'cons url cb) + elfeed-curl--refcount (length url))) + (push (cons url cb) elfeed-curl--requests) + (setf elfeed-curl--refcount 1)) + (set-process-query-on-exit-flag process nil) + (setf (process-sentinel process) #'elfeed-curl--sentinel))))) + +(defun elfeed-curl--request-key (url headers method data) + "Try to fetch URLs with matching keys at the same time." + (unless (listp url) + (let* ((urlobj (url-generic-parse-url url))) + (list (url-type urlobj) + (url-host urlobj) + (url-portspec urlobj) + headers + method + data)))) + +(defun elfeed-curl--queue-consolidate (queue-in) + "Group compatible requests together and return a new queue. +Compatible means the requests have the same protocol, domain, +port, headers, method, and body, allowing them to be used safely +in the same curl invocation." + (let ((table (make-hash-table :test 'equal)) + (keys ()) + (queue-out ())) + (dolist (entry queue-in) + (cl-destructuring-bind (url _ headers method data) entry + (let* ((key (elfeed-curl--request-key url headers method data))) + (push key keys) + (push entry (gethash key table nil))))) + (dolist (key (nreverse keys)) + (let ((entry (gethash key table))) + (when entry + (let ((rotated (list (nreverse (cl-mapcar #'car entry)) + (nreverse (cl-mapcar #'cadr entry)) + (cl-caddar entry) + (elt (car entry) 3) + (elt (car entry) 4)))) + (push rotated queue-out) + (setf (gethash key table) nil))))) + (nreverse queue-out))) + +(defun elfeed-curl--queue-wrap (cb) + "Wrap the curl CB so that it operates the queue." + (lambda (status) + (cl-decf elfeed-curl-queue-active) + (elfeed-curl--run-queue) + (funcall cb status))) + +(defvar elfeed-curl--run-queue-queued nil + "Non-nil if run-queue has already been queued for the next turn.") + +(defun elfeed-curl--run-queue () + "Possibly fire off some new requests." + (when elfeed-curl--run-queue-queued + (setf elfeed-curl--run-queue-queued nil + ;; Try to consolidate the new requests. + elfeed-curl-queue + (elfeed-curl--queue-consolidate elfeed-curl-queue))) + (while (and (< elfeed-curl-queue-active elfeed-curl-max-connections) + (> (length elfeed-curl-queue) 0)) + (cl-destructuring-bind (url cb headers method data) (pop elfeed-curl-queue) + (elfeed-log 'debug "retrieve %s" url) + (cl-incf elfeed-curl-queue-active 1) + (elfeed-curl-retrieve + url + (if (functionp cb) + (elfeed-curl--queue-wrap cb) + (cons (elfeed-curl--queue-wrap (car cb)) + (cdr cb))) + :headers headers + :method method + :data data)))) + +(cl-defun elfeed-curl-enqueue (url cb &key headers method data) + "Just like `elfeed-curl-retrieve', but restricts concurrent fetches." + (unless (or (stringp url) + (and (listp url) (cl-every #'stringp url))) + ;; Signal error synchronously instead of asynchronously in the timer + (signal 'wrong-type-argument (list 'string-p-or-string-list-p url))) + (let ((entry (list url cb headers method data))) + (setf elfeed-curl-queue (nconc elfeed-curl-queue (list entry))) + (unless elfeed-curl--run-queue-queued + (run-at-time 0 nil #'elfeed-curl--run-queue) + (setf elfeed-curl--run-queue-queued t)))) + +(provide 'elfeed-curl) + +;;; elfeed-curl.el ends here blob - /dev/null blob + 4000a0bb900b562f546be94d77a29025fe109cfb (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-db.el @@ -0,0 +1,646 @@ +;;; elfeed-db.el --- database and model for elfeed -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;;; Commentary: + +;; Elfeed is aware of two type of things: feeds and entries. All dates +;; are stored as floating point epoch seconds. + +;; Feeds are keyed by their user-provided feed URL, which acts as the +;; feed identity regardless of any other stated identity. Feeds have a +;; list of entries. + +;; Entries are keyed in order of preference by id (Atom), guid (RSS), +;; or link. To avoid circular references, entries refer to their +;; parent feeds by URL. + +;; Feed content is stored in a content-addressable loose-file +;; database, very similar to an unpacked Git object database. Entries +;; have references to items in this database (elfeed-ref), keeping the +;; actual entry struct memory footprint small. Most importantly, this +;; keeps the core index small so that it can quickly be written as a +;; whole to the filesystem. The wire format is just the s-expression +;; print form of the top-level hash table. + +;; The database can be compacted into a small number of compressed +;; files with the interactive function `elfeed-db-compact'. This could +;; be used as a kill-emacs hook. + +;; An AVL tree containing all database entries ordered by date is +;; maintained as part of the database. We almost always want to look +;; at entries ordered by date and this step accomplished that very +;; efficiently with the AVL tree. This is the reasoning behind the +;; `with-elfeed-db-visit' interface. + +;; Unfortunately there's a nasty bug (bug#15190) in the reader that +;; makes hash tables and `print-circle' incompatible. It's been fixed +;; in trunk, but many users will likely be stuck with this bug for the +;; next few years. This means the database format can't exploit +;; circular references. + +;; Entry and feed objects can have arbitrary metadata attached, +;; automatically stored in the database. The setf-able `elfeed-meta' +;; function is used to access these. + +;;; Code: + +(require 'cl-lib) +(require 'avl-tree) +(require 'elfeed-lib) + +(defcustom elfeed-db-directory "~/.elfeed" + "Directory where elfeed will store its database." + :group 'elfeed + :type 'directory) + +(defvar elfeed-db nil + "The core database for elfeed.") + +(defvar elfeed-db-feeds nil + "Feeds hash table, part of `elfeed-db'.") + +(defvar elfeed-db-entries nil + "Entries hash table, part of `elfeed-db'.") + +(defvar elfeed-db-index nil + "Collection of all entries sorted by date, part of `elfeed-db'.") + +(defvar elfeed-db-version + ;; If records are avaiable (Emacs 26), use the newer database format + (if (functionp 'record) + 4 + "0.0.3") + "The database version this version of Elfeed expects to use.") + +(defvar elfeed-new-entry-hook () + "Functions in this list are called with the new entry as its argument. +This is a chance to add custom tags to new entries.") + +(defvar elfeed-db-update-hook () + "Functions in this list are called with no arguments any time +the :last-update time is updated.") + +(defvar elfeed-db-unload-hook () + "Hook to run immediately after `elfeed-db-unload'.") + +;; Data model: + +(cl-defstruct (elfeed-feed (:constructor elfeed-feed--create)) + "A web feed, contains elfeed-entry structs." + id url title author meta) + +(cl-defstruct (elfeed-entry (:constructor elfeed-entry--create)) + "A single entry from a feed, normalized towards Atom." + id title link date content content-type enclosures tags feed-id meta) + +(defun elfeed-entry-merge (a b) + "Merge B into A, preserving A's tags. Return true if an actual +update occurred, not counting content." + (setf (elfeed-entry-tags b) (elfeed-entry-tags a) + (elfeed-entry-content a) (elfeed-entry-content b)) + (cl-loop for (key value) on (elfeed-entry-meta b) by #'cddr + do (setf (elfeed-entry-meta a) + (plist-put (elfeed-entry-meta a) key value))) + (not + (zerop + (cl-loop for i from 1 below (1- (length a)) + for part-a = (aref a i) + for part-b = (aref b i) + count (not (equal part-a part-b)) + do (setf (aref a i) part-b))))) + +(defun elfeed-db-get-feed (id) + "Get/create the feed for ID." + (elfeed-db-ensure) + (let ((feed (gethash id elfeed-db-feeds))) + (or feed + (setf (gethash id elfeed-db-feeds) + (elfeed-feed--create :id id))))) + +(defun elfeed-db-get-entry (id) + "Get the entry for ID." + (elfeed-db-ensure) + (gethash id elfeed-db-entries)) + +(defun elfeed-db-compare (a b) + "Return true if entry A is newer than entry B." + (let* ((entry-a (elfeed-db-get-entry a)) + (entry-b (elfeed-db-get-entry b)) + (date-a (elfeed-entry-date entry-a)) + (date-b (elfeed-entry-date entry-b))) + (if (= date-a date-b) + (string< (prin1-to-string b) (prin1-to-string a)) + (> date-a date-b)))) + +(defun elfeed-db-set-update-time () + "Update the database last-update time." + (setf elfeed-db (plist-put elfeed-db :last-update (float-time))) + (run-hooks 'elfeed-db-update-hook)) + +(defun elfeed-db-add (entries) + "Add ENTRIES to the database." + (elfeed-db-ensure) + (cl-loop for entry in entries + for id = (elfeed-entry-id entry) + for original = (gethash id elfeed-db-entries) + for new-date = (elfeed-entry-date entry) + for original-date = (and original (elfeed-entry-date original)) + do (elfeed-deref-entry entry) + when original count + (if (= new-date original-date) + (elfeed-entry-merge original entry) + (avl-tree-delete elfeed-db-index id) + (prog1 (elfeed-entry-merge original entry) + (avl-tree-enter elfeed-db-index id))) + into change-count + else count + (setf (gethash id elfeed-db-entries) entry) + into change-count + and do + (progn + (avl-tree-enter elfeed-db-index id) + (cl-loop for hook in elfeed-new-entry-hook + do (funcall hook entry))) + finally + (unless (zerop change-count) + (elfeed-db-set-update-time))) + :success) + +(defun elfeed-entry-feed (entry) + "Get the feed struct for ENTRY." + (elfeed-db-get-feed (elfeed-entry-feed-id entry))) + +(defun elfeed-normalize-tags (tags &rest more-tags) + "Return the normalized tag list for TAGS." + (let ((all (apply #'append tags (nconc more-tags (list ()))))) + (cl-delete-duplicates (cl-sort all #'string< :key #'symbol-name)))) + +(defun elfeed-tag-1 (entry &rest tags) + "Add TAGS to ENTRY." + (let ((current (elfeed-entry-tags entry))) + (setf (elfeed-entry-tags entry) + (elfeed-normalize-tags (append tags current))))) + +(defun elfeed-untag-1 (entry &rest tags) + "Remove TAGS from ENTRY." + (setf (elfeed-entry-tags entry) + (cl-loop for tag in (elfeed-entry-tags entry) + unless (memq tag tags) collect tag))) + +(defun elfeed-tag (entry-or-entry-list &rest tags) + "Add TAGS to ENTRY-OR-ENTRY-LIST and run `elfeed-tag-hooks'." + (let* ((entries (if (elfeed-entry-p entry-or-entry-list) + (list entry-or-entry-list) + entry-or-entry-list))) + (run-hook-with-args 'elfeed-tag-hooks entries tags) + (cl-loop for entry in entries do (apply #'elfeed-tag-1 entry tags)))) + +(defun elfeed-untag (entry-or-entry-list &rest tags) + "Remove TAGS from ENTRY-OR-ENTRY-LIST and run `elfeed-untag-hooks'." + (let* ((entries (if (elfeed-entry-p entry-or-entry-list) + (list entry-or-entry-list) + entry-or-entry-list))) + (run-hook-with-args 'elfeed-untag-hooks entries tags) + (cl-loop for entry in entries do (apply #'elfeed-untag-1 entry tags)))) + +(defun elfeed-tagged-p (tag entry) + "Return true if ENTRY is tagged by TAG." + (memq tag (elfeed-entry-tags entry))) + +(defun elfeed-db-last-update () + "Return the last database update time in (`float-time') seconds." + (elfeed-db-ensure) + (or (plist-get elfeed-db :last-update) 0)) + +(defmacro with-elfeed-db-visit (entry-and-feed &rest body) + "Visit each entry in the database from newest to oldest. +Use `elfeed-db-return' to exit early and optionally return data. + + (with-elfeed-db-visit (entry feed) + (do-something entry) + (when (some-date-criteria-p entry) + (elfeed-db-return)))" + (declare (indent defun)) + `(catch 'elfeed-db-done + (prog1 nil + (elfeed-db-ensure) + (avl-tree-mapc + (lambda (id) + (let* ((,(cl-first entry-and-feed) (elfeed-db-get-entry id)) + (,(cl-second entry-and-feed) + (elfeed-entry-feed ,(cl-first entry-and-feed)))) + ,@body)) + elfeed-db-index)))) + +(defun elfeed-feed-entries (feed-or-id) + "Return a list of all entries for a particular feed. +The FEED-OR-ID may be a feed struct or a feed ID (url)." + (let ((feed-id (if (elfeed-feed-p feed-or-id) + (elfeed-feed-id feed-or-id) + feed-or-id))) + (let ((entries)) + (with-elfeed-db-visit (entry feed) + (when (equal (elfeed-feed-id feed) feed-id) + (push entry entries))) + (nreverse entries)))) + +(defun elfeed-apply-hooks-now () + "Apply `elfeed-new-entry-hook' to all entries in the database." + (interactive) + (with-elfeed-db-visit (entry _) + (cl-loop for hook in elfeed-new-entry-hook + do (funcall hook entry)))) + +(defmacro elfeed-db-return (&optional value) + "Use this to exit early and return VALUE from `with-elfeed-db-visit'." + `(throw 'elfeed-db-done ,value)) + +(defun elfeed-db-get-all-tags () + "Return a list of all tags currently in the database." + (let ((table (make-hash-table :test 'eq))) + (with-elfeed-db-visit (e _) + (dolist (tag (elfeed-entry-tags e)) + (setf (gethash tag table) tag))) + (let ((tags ())) + (maphash (lambda (k _) (push k tags)) table) + (cl-sort tags #'string< :key #'symbol-name)))) + +;; Saving and Loading: + +(defun elfeed-db-save () + "Write the database index to the filesystem." + (elfeed-db-ensure) + (setf elfeed-db (plist-put elfeed-db :version elfeed-db-version)) + (mkdir elfeed-db-directory t) + (let ((coding-system-for-write 'utf-8)) + (with-temp-file (expand-file-name "index" elfeed-db-directory) + (let ((standard-output (current-buffer)) + (print-level nil) + (print-length nil) + (print-circle nil)) + (princ (format ";;; Elfeed Database Index (version %s)\n\n" + elfeed-db-version)) + (when (eql elfeed-db-version 4) + ;; Put empty dummy index in front + (princ ";; Dummy index for backwards compatablity:\n") + (prin1 (elfeed-db--dummy)) + (princ "\n\n;; Real index:\n")) + (prin1 elfeed-db) + :success)))) + +(defun elfeed-db-save-safe () + "Run `elfeed-db-save' without triggering any errors, for use as a safe hook." + (ignore-errors (elfeed-db-save))) + +(defun elfeed-db-upgrade (db) + "Upgrade the database from a previous format." + (if (not (vectorp (plist-get db :index))) + db ; Database is already in record format + (let* ((new-db (elfeed-db--empty)) + ;; Dynamically bind for other functions + (elfeed-db-feeds (plist-get new-db :feeds)) + (elfeed-db-entries (plist-get new-db :entries)) + (elfeed-db-index (plist-get new-db :index))) + ;; Fix up feeds + (cl-loop with table = (plist-get new-db :feeds) + for feed hash-values of (plist-get db :feeds) + for id = (aref feed 1) + for fixed = (elfeed-feed--create + :id id + :url (aref feed 2) + :title (aref feed 3) + :author (aref feed 4) + :meta (aref feed 5)) + do (setf (gethash id table) fixed)) + ;; Fix up entries + (cl-loop with table = (plist-get new-db :entries) + with index = (plist-get new-db :index) + for entry hash-values of (plist-get db :entries) + for id = (aref entry 1) + for content = (aref entry 5) + for fixed = (elfeed-entry--create + :id id + :title (aref entry 2) + :link (aref entry 3) + :date (aref entry 4) + :content (if (vectorp content) + (elfeed-ref--create + :id (aref content 1)) + content) + :content-type (aref entry 6) + :enclosures (aref entry 7) + :tags (aref entry 8) + :feed-id (aref entry 9) + :meta (aref entry 10)) + do (setf (gethash id table) fixed) + do (avl-tree-enter index id)) + (plist-put new-db :last-update (plist-get db :last-update))))) + +(defun elfeed-db--empty () + "Create an empty database object." + `(:version ,elfeed-db-version + :feeds ,(make-hash-table :test 'equal) + :entries ,(make-hash-table :test 'equal) + ;; Compiler may warn about this (bug#15327): + :index ,(avl-tree-create #'elfeed-db-compare))) + +(defun elfeed-db--dummy () + "Create an empty dummy database for Emacs 25 and earlier." + (list :version "0.0.3" + :feeds #s(hash-table size 65 + test equal + rehash-size 1.5 + rehash-threshold 0.8 + data ()) + :entries #s(hash-table size 65 + test equal + rehash-size 1.5 + rehash-threshold 0.8 + data ()) + :index [cl-struct-avl-tree- [nil nil nil 0] elfeed-db-compare])) + +;; To cope with the incompatible struct changes in Emacs 26, Elfeed +;; uses version 4 of the database format when run under Emacs 26. This +;; version saves a dummy, empty index in front of the real database. A +;; user going from Emacs 26 to Emacs 25 will quietly load an empty +;; index since it's unreasonable to downgrade (would require rewriting +;; the Emacs reader from scratch). + +(defun elfeed-db-load () + "Load the database index from the filesystem." + (let ((index (expand-file-name "index" elfeed-db-directory)) + (enable-local-variables nil)) ; don't set local variables from index! + (if (not (file-exists-p index)) + (setf elfeed-db (elfeed-db--empty)) + ;; Override the default value for major-mode. There is no + ;; preventing find-file-noselect from starting the default major + ;; mode while also having it handle buffer conversion. Some + ;; major modes crash Emacs when enabled in large buffers (e.g. + ;; org-mode). This includes the Elfeed index, so we must not let + ;; this happen. + (cl-letf (((default-value 'major-mode) 'fundamental-mode)) + (with-current-buffer (find-file-noselect index :nowarn) + (goto-char (point-min)) + (if (eql elfeed-db-version 4) + ;; May need to skip over dummy database + (let ((db-1 (read (current-buffer))) + (db-2 (ignore-errors (read (current-buffer))))) + (setf elfeed-db (or db-2 db-1))) + ;; Just load first database + (setf elfeed-db (read (current-buffer)))) + (kill-buffer)))) + ;; Perform an upgrade if necessary and possible + (unless (equal (plist-get elfeed-db :version) elfeed-db-version) + (ignore-errors + (copy-file index (concat index ".backup"))) + (message "Upgrading Elfeed index for Emacs 26 ...") + (setf elfeed-db (elfeed-db-upgrade elfeed-db)) + (message "Elfeed index upgrade complete.")) + (setf elfeed-db-feeds (plist-get elfeed-db :feeds) + elfeed-db-entries (plist-get elfeed-db :entries) + elfeed-db-index (plist-get elfeed-db :index) + ;; Internal function use required for security! + (avl-tree--cmpfun elfeed-db-index) #'elfeed-db-compare))) + +(defun elfeed-db-unload () + "Unload the database so that it can be operated on externally. + +Runs `elfeed-db-unload-hook' after unloading the database." + (interactive) + (elfeed-db-save) + (setf elfeed-db nil + elfeed-db-feeds nil + elfeed-db-entries nil + elfeed-db-index nil) + (run-hooks 'elfeed-db-unload-hook)) + +(defun elfeed-db-ensure () + "Ensure that the database has been loaded." + (when (null elfeed-db) (elfeed-db-load))) + +(defun elfeed-db-size () + "Return a count of the number of entries in the database." + (let ((count-table (hash-table-count elfeed-db-entries)) + (count-tree (avl-tree-size elfeed-db-index))) + (if (= count-table count-tree) + count-table + (error "Elfeed database error: entry count mismatch.")))) + +;; Metadata: + +(defun elfeed-meta--plist (thing) + "Get the metadata plist for THING." + (cl-typecase thing + (elfeed-feed (elfeed-feed-meta thing)) + (elfeed-entry (elfeed-entry-meta thing)) + (otherwise (error "Don't know how to access metadata on %S" thing)))) + +(defun elfeed-meta--set-plist (thing plist) + "Set the metadata plist on THING to PLIST." + (cl-typecase thing + (elfeed-feed (setf (elfeed-feed-meta thing) plist)) + (elfeed-entry (setf (elfeed-entry-meta thing) plist)) + (otherwise (error "Don't know how to access metadata on %S" thing)))) + +(defun elfeed-db--plist-fixup (plist) + "Remove nil values from PLIST." + (cl-loop for (k v) on plist by #'cddr + when (not (null v)) + collect k and collect v)) + +(defun elfeed-meta (thing key &optional default) + "Access metadata for THING (entry, feed) under KEY." + (or (plist-get (elfeed-meta--plist thing) key) + default)) + +(defun elfeed-meta--put (thing key value) + "Set metadata to VALUE on THING under KEY." + (when (not (elfeed-readable-p value)) (error "New value must be readable.")) + (let ((new-plist (plist-put (elfeed-meta--plist thing) key value))) + (prog1 value + (elfeed-meta--set-plist thing (elfeed-db--plist-fixup new-plist))))) + +(gv-define-setter elfeed-meta (value thing key &optional _default) + `(elfeed-meta--put ,thing ,key ,value)) + +;; Filesystem storage: + +(defvar elfeed-ref-archive nil + "Index of archived/packed content.") + +(defvar elfeed-ref-cache nil + "Temporary storage of the full archive content.") + +(cl-defstruct (elfeed-ref (:constructor elfeed-ref--create)) + id) + +(defun elfeed-ref--file (ref) + "Determine the storage filename for REF." + (let* ((id (elfeed-ref-id ref)) + (root (expand-file-name "data" elfeed-db-directory)) + (subdir (expand-file-name (substring id 0 2) root))) + (expand-file-name id subdir))) + +(cl-defun elfeed-ref-archive-filename (&optional (suffix "")) + "Return the base filename of the archive files." + (concat (expand-file-name "data/archive" elfeed-db-directory) suffix)) + +(defun elfeed-ref-archive-load () + "Load the archived ref index." + (let ((archive-index (elfeed-ref-archive-filename ".index"))) + (if (file-exists-p archive-index) + (with-temp-buffer + (insert-file-contents archive-index) + (setf elfeed-ref-archive (read (current-buffer)))) + (setf elfeed-ref-archive :empty)))) + +(defun elfeed-ref-archive-ensure () + "Ensure that the archive index is loaded." + (when (null elfeed-ref-archive) (elfeed-ref-archive-load))) + +(defun elfeed-ref-exists-p (ref) + "Return true if REF can be dereferenced." + (elfeed-ref-archive-ensure) + (or (and (hash-table-p elfeed-ref-archive) + (not (null (gethash (elfeed-ref-id ref) elfeed-ref-archive)))) + (file-exists-p (elfeed-ref--file ref)))) + +(defun elfeed-deref (ref) + "Fetch the content behind the reference, or nil if non-existent." + (elfeed-ref-archive-ensure) + (if (not (elfeed-ref-p ref)) + ref + (let ((index (and (hash-table-p elfeed-ref-archive) + (gethash (elfeed-ref-id ref) elfeed-ref-archive))) + (archive-file (elfeed-ref-archive-filename ".gz")) + (coding-system-for-read 'utf-8)) + (if (and index (file-exists-p archive-file)) + (progn + (when (null elfeed-ref-cache) + (with-temp-buffer + (insert-file-contents archive-file) + (setf elfeed-ref-cache (buffer-string))) + ;; Clear cache on next turn. + (run-at-time 0 nil (lambda () (setf elfeed-ref-cache nil)))) + (substring elfeed-ref-cache (car index) (cdr index))) + (let ((file (elfeed-ref--file ref))) + (when (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (buffer-string)))))))) + +(defun elfeed-ref (content) + "Create a reference to CONTENT, to be persistently stored." + (if (elfeed-ref-p content) + content + (let* ((id (secure-hash 'sha1 (encode-coding-string content 'utf-8 t))) + (ref (elfeed-ref--create :id id)) + (file (elfeed-ref--file ref))) + (prog1 ref + (unless (elfeed-ref-exists-p ref) + (mkdir (file-name-directory file) t) + (let ((coding-system-for-write 'utf-8) + ;; Content data loss is a tolerable risk. + ;; Fsync will occur soon on index write anyway. + (write-region-inhibit-fsync t)) + (with-temp-file file + (insert content)))))))) + +(defun elfeed-deref-entry (entry) + "Move ENTRY's content to filesystem storage. Return the entry." + (let ((content (elfeed-entry-content entry))) + (prog1 entry + (when (stringp content) + (setf (elfeed-entry-content entry) (elfeed-ref content)))))) + +(defun elfeed-ref-delete (ref) + "Remove the content behind REF from the database." + (ignore-errors + (delete-file (elfeed-ref--file ref)))) + +(defun elfeed-db-gc-empty-feeds () + "Remove feeds with no entries from the database." + (let ((seen (make-hash-table :test 'equal))) + (with-elfeed-db-visit (entry feed) + (setf (gethash (elfeed-feed-id feed) seen) feed)) + (maphash (lambda (id _) + (unless (gethash id seen) + (remhash id elfeed-db-feeds))) + elfeed-db-feeds))) + +(defun elfeed-db-gc (&optional stats-p) + "Clean up unused content from the content database. +If STATS is true, return the space cleared in bytes." + (elfeed-db-gc-empty-feeds) + (let* ((data (expand-file-name "data" elfeed-db-directory)) + (dirs (directory-files data t "^[0-9a-z]\\{2\\}$")) + (ids (cl-mapcan (lambda (d) (directory-files d nil nil t)) dirs)) + (table (make-hash-table :test 'equal))) + (dolist (id ids) + (setf (gethash id table) nil)) + (with-elfeed-db-visit (entry _) + (let ((content (elfeed-entry-content entry))) + (when (elfeed-ref-p content) + (setf (gethash (elfeed-ref-id content) table) t)))) + (cl-loop for id hash-keys of table using (hash-value used) + for used-p = (or used (member id '("." ".."))) + when (and (not used-p) stats-p) + sum (let* ((ref (elfeed-ref--create :id id)) + (file (elfeed-ref--file ref))) + (* 1.0 (nth 7 (file-attributes file)))) + unless used-p + do (elfeed-ref-delete (elfeed-ref--create :id id)) + finally (cl-loop for dir in dirs + when (elfeed-directory-empty-p dir) + do (delete-directory dir))))) + +(defun elfeed-db-pack () + "Pack all content into a single archive for efficient storage." + (let ((coding-system-for-write 'utf-8) + (next-archive (make-hash-table :test 'equal)) + (packed ())) + (make-directory (expand-file-name "data" elfeed-db-directory) t) + (with-temp-file (elfeed-ref-archive-filename ".gz") + (with-elfeed-db-visit (entry _) + (let ((ref (elfeed-entry-content entry)) + (start (1- (point)))) + (when (elfeed-ref-p ref) + (let ((content (elfeed-deref ref))) + (when content + (push ref packed) + (insert content) + (setf (gethash (elfeed-ref-id ref) next-archive) + (cons start (1- (point)))))))))) + (with-temp-file (elfeed-ref-archive-filename ".index") + (let ((standard-output (current-buffer)) + (print-level nil) + (print-length nil) + (print-circle nil)) + (prin1 next-archive))) + (setf elfeed-ref-cache nil) + (setf elfeed-ref-archive next-archive) + (mapc #'elfeed-ref-delete packed) + :success)) + +(defun elfeed-db-compact () + "Minimize the Elfeed database storage size on the filesystem. +This requires that auto-compression-mode can handle +gzip-compressed files, so the gzip program must be in your PATH." + (interactive) + (unless (elfeed-gzip-supported-p) + (error "aborting compaction: gzip auto-compression-mode unsupported")) + (elfeed-db-pack) + (elfeed-db-gc)) + +(defun elfeed-db-gc-safe () + "Run `elfeed-db-gc' without triggering any errors, for use as a safe hook." + (ignore-errors (elfeed-db-gc))) + +(unless noninteractive + (add-hook 'kill-emacs-hook #'elfeed-db-gc-safe :append) + (add-hook 'kill-emacs-hook #'elfeed-db-save-safe)) + +(provide 'elfeed-db) + +;;; elfeed-db.el ends here blob - /dev/null blob + c790f382a814aeb62b304a8ca295fb86e2a32120 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-lib.el @@ -0,0 +1,385 @@ +;;; elfeed-lib.el --- misc functions for elfeed -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;;; Commentary: + +;; These are general functions that aren't specific to web feeds. It's +;; a library of useful functions to Elfeed. + +;;; Code: + +(require 'cl-lib) +(require 'thingatpt) +(require 'time-date) +(require 'url-parse) +(require 'url-util) +(require 'xml) + +(defun elfeed-expose (function &rest args) + "Return an interactive version of FUNCTION, \"exposing\" it to the user." + (lambda () (interactive) (apply function args))) + +(defun elfeed-goto-line (n) + "Like `goto-line' but for non-interactive use." + (goto-char (point-min)) + (forward-line (1- n))) + +(defun elfeed-kill-buffer () + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun elfeed-kill-line () + "Clear out the current line without touching anything else." + (beginning-of-line) + (let ((start (point))) + (end-of-line) + (delete-region start (point)))) + +(defun elfeed-time-duration (time &optional now) + "Turn a time expression into a number of seconds. Uses +`timer-duration' but allows a bit more flair. + +If `now' is non-nil, use it as the current time (`float-time'). This +is mostly useful for testing." + (cond + ((numberp time) time) + ((let ((iso-time (elfeed-parse-simple-iso-8601 time))) + (when iso-time (- (or now (float-time)) iso-time)))) + ((string-match-p "[[:alpha:]]" time) + (let* ((clean (replace-regexp-in-string "\\(ago\\|old\\|-\\)" " " time)) + (duration (timer-duration clean))) + ;; convert to float since float-time is used elsewhere + (when duration (float duration)))))) + +(defun elfeed-looks-like-url-p (string) + "Return true if STRING looks like it could be a URL." + (and (stringp string) + (not (string-match-p "[ \n\t\r]" string)) + (not (null (url-type (url-generic-parse-url string)))))) + +(defun elfeed-format-column (string width &optional align) + "Return STRING truncated or padded to WIDTH following ALIGNment. +Align should be a keyword :left or :right." + (if (<= width 0) + "" + (format (format "%%%s%d.%ds" (if (eq align :left) "-" "") width width) + string))) + +(defun elfeed-clamp (min value max) + "Clamp a value between two values." + (min max (max min value))) + +(defun elfeed-valid-regexp-p (regexp) + "Return t if REGEXP is a valid REGEXP." + (ignore-errors + (prog1 t + (string-match-p regexp "")))) + +(defun elfeed-cleanup (name) + "Trim trailing and leading spaces and collapse multiple spaces." + (let ((trim (replace-regexp-in-string "[\f\n\r\t\v ]+" " " (or name "")))) + (replace-regexp-in-string "^ +\\| +$" "" trim))) + +(defun elfeed-parse-simple-iso-8601 (string) + "Attempt to parse STRING as a simply formatted ISO 8601 date. +Examples: 2015-02-22, 2015-02, 20150222" + (let* ((re (cl-flet ((re-numbers (num) (format "\\([0-9]\\{%s\\}\\)" num))) + (format "^%s-?%s-?%s?\\(T%s:%s:?%s?\\)?" + (re-numbers 4) + (re-numbers 2) + (re-numbers 2) + (re-numbers 2) + (re-numbers 2) + (re-numbers 2)))) + (matches (save-match-data + (when (string-match re string) + (cl-loop for i from 1 to 7 + collect (let ((match (match-string i string))) + (and match (string-to-number match)))))))) + (when matches + (cl-multiple-value-bind (year month day _ hour min sec) matches + (float-time (encode-time (or sec 0) (or min 0) (or hour 0) + (or day 1) month year t)))))) + +(defun elfeed-new-date-for-entry (old-date new-date) + "Decide entry date, given an existing date (nil for new) and a new date. +Existing entries' dates are unchanged if the new date is not +parseable. New entries with unparseable dates default to the +current time." + (or (elfeed-float-time new-date) + old-date + (float-time))) + +(defun elfeed-float-time (date) + "Like `float-time' but accept anything reasonable for DATE. +Defaults to nil if DATE could not be parsed. Date is allowed to +be relative to now (`elfeed-time-duration')." + (cl-typecase date + (string + (let ((iso-8601 (elfeed-parse-simple-iso-8601 date))) + (if iso-8601 + iso-8601 + (let ((duration (elfeed-time-duration date))) + (if duration + (- (float-time) duration) + (let ((time (ignore-errors (date-to-time date)))) + ;; check if date-to-time failed, silently or otherwise + (unless (or (null time) (equal time '(14445 17280))) + (float-time time)))))))) + (integer date) + (otherwise nil))) + +(defun elfeed-xml-parse-region (&optional beg end buffer parse-dtd _parse-ns) + "Decode (if needed) and parse XML file. Uses coding system from +XML encoding declaration." + (unless beg (setq beg (point-min))) + (unless end (setq end (point-max))) + (goto-char beg) + (when (re-search-forward + "<\\?xml.*?encoding=[\"']\\([^\"']+\\)[\"'].*?\\?>" nil t) + (let ((coding-system (intern-soft (downcase (match-string 1))))) + (when (ignore-errors (check-coding-system coding-system)) + (let ((mark-beg (make-marker)) + (mark-end (make-marker))) + ;; Region changes with encoding, so use markers to track it. + (set-marker mark-beg beg) + (set-marker mark-end end) + (set-buffer-multibyte t) + (recode-region mark-beg mark-end coding-system 'raw-text) + (setf beg (marker-position mark-beg) + end (marker-position mark-end)))))) + (let ((xml-default-ns ())) + (xml-parse-region beg end buffer parse-dtd 'symbol-qnames))) + +(defun elfeed-xml-unparse (element) + "Inverse of `elfeed-xml-parse-region', writing XML to the buffer." + (cl-destructuring-bind (tag attrs . body) element + (insert (format "<%s" tag)) + (dolist (attr attrs) + (cl-destructuring-bind (key . value) attr + (insert (format " %s='%s'" key (xml-escape-string value))))) + (if (null body) + (insert "/>") + (insert ">") + (dolist (sub body) + (if (stringp sub) + (insert (xml-escape-string sub)) + (elfeed-xml-unparse sub))) + (insert (format "" tag))))) + +(defun elfeed-directory-empty-p (dir) + "Return non-nil if DIR is empty." + (null (cddr (directory-files dir)))) + +(defun elfeed-slurp (file &optional literally) + "Return the contents of FILE as a string." + (with-temp-buffer + (if literally + (insert-file-contents-literally file) + (insert-file-contents file)) + (buffer-string))) + +(cl-defun elfeed-spit (file string &key fsync append (encoding 'utf-8)) + "Write STRING to FILE." + (let ((coding-system-for-write encoding) + (write-region-inhibit-fsync (not fsync))) + (with-temp-buffer + (insert string) + (write-region nil nil file append 0)))) + +(defvar elfeed-gzip-supported-p--cache :unknown + "To avoid running the relatively expensive test more than once.") + +(defun elfeed-gzip-supported-p () + "Return non-nil if `auto-compression-mode' can handle gzip." + (if (not (eq elfeed-gzip-supported-p--cache :unknown)) + elfeed-gzip-supported-p--cache + (setf elfeed-gzip-supported-p--cache + (and (executable-find "gzip") + (ignore-errors + (save-window-excursion + (let ((file (make-temp-file "gziptest" nil ".gz")) + (data (cl-loop for i from 32 to 3200 + collect i into chars + finally + (return (apply #'string chars))))) + (unwind-protect + (progn + (elfeed-spit file data) + (and (string= data (elfeed-slurp file)) + (not (string= data (elfeed-slurp file t))))) + (delete-file file))))))))) + +(defun elfeed-libxml-supported-p () + "Return non-nil if `libxml-parse-html-region' is available." + (with-temp-buffer + (insert "") + (and (fboundp 'libxml-parse-html-region) + (not (null (libxml-parse-html-region (point-min) (point-max))))))) + +(defun elfeed-keyword->symbol (keyword) + "If a keyword, convert KEYWORD into a plain symbol (remove the colon)." + (if (keywordp keyword) + (intern (substring (symbol-name keyword) 1)) + keyword)) + +(defun elfeed-resize-vector (vector length) + "Return a copy of VECTOR set to size LENGTH." + (let ((new-vector (make-vector length nil))) + (prog1 new-vector ; don't use dotimes result (bug#16206) + (dotimes (i (min (length new-vector) (length vector))) + (setf (aref new-vector i) (aref vector i)))))) + +(defun elfeed-readable-p (value) + "Return non-nil if VALUE can be serialized." + (condition-case _ + (prog1 t (read (prin1-to-string value))) + (error nil))) + +(defun elfeed-strip-properties (string) + "Return a copy of STRING with all properties removed. +If STRING is nil, returns nil." + (when string + (let ((copy (copy-sequence string))) + (prog1 copy + (set-text-properties 0 (length copy) nil copy))))) + +(defun elfeed-clipboard-get () + "Try to get a sensible value from the system clipboard. +On systems running X, it will try to use the PRIMARY selection +first, then fall back onto the standard clipboard like other +systems." + (elfeed-strip-properties + (or (and (fboundp 'x-get-selection) + (funcall 'x-get-selection)) + (and (functionp interprogram-paste-function) + (funcall interprogram-paste-function)) + (and (fboundp 'w32-get-clipboard-data) + (funcall 'w32-get-clipboard-data)) + (ignore-errors + (current-kill 0 :non-destructively))))) + +(defun elfeed-get-link-at-point () + "Try to a link at point and return its URL." + (or (get-text-property (point) 'shr-url) + (and (fboundp 'eww-current-url) + (funcall 'eww-current-url)) + (get-text-property (point) :nt-link))) + +(defun elfeed-get-url-at-point () + "Try to get a plain URL at point." + (or (if (fboundp 'thing-at-point-url-at-point) + (thing-at-point-url-at-point) + (with-no-warnings (url-get-url-at-point))) + (thing-at-point 'url))) + +(defun elfeed-move-to-first-empty-line () + "Place point after first blank line, for use with `url-retrieve'. +If no such line exists, point is left in place." + (let ((start (point))) + (goto-char (point-min)) + (unless (search-forward-regexp "^$" nil t) + (goto-char start)))) + +(defun elfeed--shuffle (seq) + "Destructively shuffle SEQ." + (let ((n (length seq))) + (prog1 seq ; don't use dotimes result (bug#16206) + (dotimes (i n) + (cl-rotatef (elt seq i) (elt seq (+ i (cl-random (- n i))))))))) + +(defun elfeed-split-ranges-to-numbers (str n) + "Convert STR containing enclosure numbers into a list of numbers. +STR is a string; N is the highest possible number in the list. +This includes expanding e.g. 3-5 into 3,4,5. If the letter +\"a\" ('all')) is given, that is expanded to a list with numbers [1..n]." + (let ((str-split (split-string str)) + beg end list) + (dolist (elem str-split list) + ;; special number "a" converts into all enclosures 1-N. + (when (equal elem "a") + (setf elem (concat "1-" (int-to-string n)))) + (if (string-match "\\([0-9]+\\)-\\([0-9]+\\)" elem) + ;; we have found a range A-B, which needs converting + ;; into the numbers A, A+1, A+2, ... B. + (progn + (setf beg (string-to-number (match-string 1 elem)) + end (string-to-number (match-string 2 elem))) + (while (<= beg end) + (setf list (nconc list (list beg)) + beg (1+ beg)))) + ;; else just a number + (push (string-to-number elem) list))))) + +(defun elfeed-remove-dot-segments (input) + "Relative URL algorithm as described in RFC 3986 §5.2.4." + (cl-loop + with output = "" + for s = input + then (cond + ((string-match-p "^\\.\\./" s) + (substring s 3)) + ((string-match-p "^\\./" s) + (substring s 2)) + ((string-match-p "^/\\./" s) + (substring s 2)) + ((string-match-p "^/\\.$" s) "/") + ((string-match-p "^/\\.\\./" s) + (setf output (replace-regexp-in-string "/?[^/]*$" "" output)) + (substring s 3)) + ((string-match-p "^/\\.\\.$" s) + (setf output (replace-regexp-in-string "/?[^/]*$" "" output)) + "/") + ((string-match-p "^\\.\\.?$" s) + "") + ((string-match "^/?[^/]*" s) + (setf output (concat output (match-string 0 s))) + (replace-regexp-in-string "^/?[^/]*" "" s))) + until (zerop (length s)) + finally return output)) + +(defun elfeed-update-location (old-url new-url) + "Return full URL for maybe-relative NEW-URL based on full OLD-URL." + (if (null new-url) + old-url + (let ((old (url-generic-parse-url old-url)) + (new (url-generic-parse-url new-url))) + (cond + ;; Is new URL absolute already? + ((url-type new) new-url) + ;; Empty is a special case (clear fragment) + ((equal new-url "") + (setf (url-target old) nil) + (url-recreate-url old)) + ;; Does it start with //? Append the old protocol. + ((url-fullness new) (concat (url-type old) ":" new-url)) + ;; Is it a relative path? + ((not (string-match-p "^/" new-url)) + (let* ((old-dir (or (file-name-directory (url-filename old)) "/")) + (concat (concat old-dir new-url)) + (new-file (elfeed-remove-dot-segments concat))) + (setf (url-filename old) nil + (url-target old) nil + (url-attributes old) nil + (url-filename old) new-file) + (url-recreate-url old))) + ;; Replace the relative part. + ((progn + (setf (url-filename old) (elfeed-remove-dot-segments new-url) + (url-target old) nil + (url-attributes old) nil) + (url-recreate-url old))))))) + +(defun elfeed-url-to-namespace (url) + "Compute an ID namespace from URL." + (let* ((urlobj (url-generic-parse-url url)) + (host (url-host urlobj))) + (if (= 0 (length host)) + url + host))) + +(provide 'elfeed-lib) + +;;; elfeed-lib.el ends here blob - /dev/null blob + 40500677a3e42f403a7cc698b08635d133d70807 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-link.el @@ -0,0 +1,82 @@ +;;; elfeed-link.el --- misc functions for elfeed -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;;; Commentary: + +;; Code for integration with org-mode. + +;; To use, add (require 'elfeed-link) somewhere in your configuration. + +;;; Code: + +(require 'org) +(require 'cl-lib) +(require 'elfeed-db) +(require 'elfeed-show) +(require 'elfeed-search) + +;;;###autoload +(defun elfeed-link-store-link () + "Store a link to an elfeed search or entry buffer. + +When storing a link to an entry, automatically extract all the +entry metadata. These can be used in the capture templates as +%:elfeed-entry-. See `elfeed-entry--create' for the list +of available props." + (cond ((derived-mode-p 'elfeed-search-mode) + (funcall (if (fboundp 'org-link-store-props) + #'org-link-store-props + (with-no-warnings #'org-store-link-props)) + :type "elfeed" + :link (format "elfeed:%s" elfeed-search-filter) + :description elfeed-search-filter)) + ((derived-mode-p 'elfeed-show-mode) + (apply + 'org-store-link-props + :type "elfeed" + :link (format "elfeed:%s#%s" + (car (elfeed-entry-id elfeed-show-entry)) + (cdr (elfeed-entry-id elfeed-show-entry))) + :description (elfeed-entry-title elfeed-show-entry) + (cl-loop for prop in + (list 'id 'title 'link 'date 'content 'content-type 'enclosures 'tags 'feed-id 'meta) + nconc (list + (intern (concat ":elfeed-entry-" (symbol-name prop))) + (funcall + (intern (concat "elfeed-entry-" (symbol-name prop))) + elfeed-show-entry))))))) + +;;;###autoload +(defun elfeed-link-open (filter-or-id) + "Jump to an elfeed entry or search. + +Depending on what FILTER-OR-ID looks like, we jump to either +search buffer or show a concrete entry." + (if (string-match "\\([^#]+\\)#\\(.+\\)" filter-or-id) + (elfeed-show-entry (elfeed-db-get-entry + (cons (match-string 1 filter-or-id) + (match-string 2 filter-or-id)))) + (elfeed) + (elfeed-search-set-filter filter-or-id))) + +;;;###autoload +(eval-after-load 'org + `(funcall + ;; The extra quote below is necessary because uncompiled closures + ;; do not evaluate to themselves. The quote is harmless for + ;; byte-compiled function objects. + ',(lambda () + (if (version< (org-version) "9.0") + (with-no-warnings + (org-add-link-type "elfeed" #'elfeed-link-open) + (add-hook 'org-store-link-functions #'elfeed-link-store-link)) + (with-no-warnings + (org-link-set-parameters + "elfeed" + :follow #'elfeed-link-open + :store #'elfeed-link-store-link)))))) + +(provide 'elfeed-link) + +;;; elfeed-link.el ends here blob - /dev/null blob + 9f91237f613c81310dcabaa0e0bd249af5931ea4 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-log.el @@ -0,0 +1,84 @@ +;;; elfeed-log.el --- Elfeed's logging system -*- lexical-binding: t; -*- + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defface elfeed-log-date-face + '((t :inherit font-lock-type-face)) + "Face for showing the date in the elfeed log buffer." + :group 'elfeed) + +(defface elfeed-log-error-level-face + '((t :foreground "red")) + "Face for showing the `error' log level in the elfeed log buffer." + :group 'elfeed) + +(defface elfeed-log-warn-level-face + '((t :foreground "goldenrod")) + "Face for showing the `warn' log level in the elfeed log buffer." + :group 'elfeed) + +(defface elfeed-log-info-level-face + '((t :foreground "deep sky blue")) + "Face for showing the `info' log level in the elfeed log buffer." + :group 'elfeed) + +(defface elfeed-log-debug-level-face + '((t :foreground "magenta2")) + "Face for showing the `debug' log level in the elfeed log buffer." + :group 'elfeed) + +(defvar elfeed-log-buffer-name "*elfeed-log*" + "Name of buffer used for logging Elfeed events.") + +(defvar elfeed-log-level 'info + "Lowest type of messages to be logged.") + +(defun elfeed-log-buffer () + "Returns the buffer for `elfeed-log', creating it as needed." + (let ((buffer (get-buffer elfeed-log-buffer-name))) + (if buffer + buffer + (with-current-buffer (generate-new-buffer elfeed-log-buffer-name) + (special-mode) + (current-buffer))))) + +(defun elfeed-log--level-number (level) + "Return a relative level number for LEVEL." + (cl-case level + (debug -10) + (info 0) + (warn 10) + (error 20) + (otherwise -10))) + +(defun elfeed-log (level fmt &rest objects) + "Write log message FMT at LEVEL to Elfeed's log buffer. + +LEVEL should be a symbol: debug, info, warn, error. +FMT must be a string suitable for `format' given OBJECTS as arguments." + (let ((log-buffer (elfeed-log-buffer)) + (log-level-face (cl-case level + (debug 'elfeed-log-debug-level-face) + (info 'elfeed-log-info-level-face) + (warn 'elfeed-log-warn-level-face) + (error 'elfeed-log-error-level-face))) + (inhibit-read-only t)) + (when (>= (elfeed-log--level-number level) + (elfeed-log--level-number elfeed-log-level)) + (with-current-buffer log-buffer + (goto-char (point-max)) + (insert + (format + (concat "[" (propertize "%s" 'face 'elfeed-log-date-face) "] " + "[" (propertize "%s" 'face log-level-face) "]: %s\n") + (format-time-string "%Y-%m-%d %H:%M:%S") + level + (apply #'format fmt objects))))))) + +(provide 'elfeed-log) + +;;; elfeed-log.el ends here blob - /dev/null blob + 1c41fcf09655a2fd95db5ca17db158855af0b3f1 (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-pkg.el @@ -0,0 +1,9 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "elfeed" "3.4.2" + "An Emacs Atom/RSS feed reader." + '((emacs "24.3")) + :url "https://github.com/skeeto/elfeed" + :commit "904b6d4feca78e7e5336d7dbb7b8ba53b8c4dac1" + :revdesc "3.4.2-0-g904b6d4feca7" + :authors '(("Christopher Wellons" . "wellons@nullprogram.com")) + :maintainers '(("Christopher Wellons" . "wellons@nullprogram.com"))) blob - /dev/null blob + 1fcfadde5a42c44d10fa9396ec33e51bdd657dbd (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-search.el @@ -0,0 +1,961 @@ +;;; elfeed-search.el --- list feed entries -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;;; Code: + +(require 'cl-lib) +(require 'browse-url) +(require 'wid-edit) ; widget-inactive face +(require 'bookmark) +(bookmark-maybe-load-default-file) + +(require 'elfeed) +(require 'elfeed-db) +(require 'elfeed-lib) + +;; Interface to elfeed-show (lazy required) +(declare-function elfeed-show-entry 'elfeed-show (entry)) + +(defvar elfeed-search-entries () + "List of the entries currently on display.") + +(defvar elfeed-search-filter-history nil + "Filter history for `completing-read'.") + +(defvar elfeed-search-last-update 0 + "The last time the buffer was redrawn in epoch seconds.") + +(defvar elfeed-search-update-hook () + "List of functions to run immediately following a search buffer update.") + +(defcustom elfeed-search-filter "@6-months-ago +unread" + "Query string filtering shown entries." + :group 'elfeed + :type 'string) + +(defcustom elfeed-sort-order 'descending + "The order in which entries should be displayed. + +Changing this from the default will lead to misleading results +during live filter editing, but the results be will correct when +live filter editing is exited. " + :group 'elfeed + :type '(choice (const descending) (const ascending))) + +(defcustom elfeed-search-sort-function nil + "Sort predicate applied to the list of entries before display. + +This function must take two entries as arguments, an interface +suitable as the predicate for `sort'. + +Changing this from the default will lead to misleading results +during live filter editing, but the results be will correct when +live filter editing is exited." + :group 'elfeed + :type '(choice function (const nil))) + +(defcustom elfeed-search-remain-on-entry nil + "When non-nil, keep point at entry after performing a command. + +When nil, move to next entry." + :group 'elfeed + :type 'boolean) + +(defcustom elfeed-search-clipboard-type 'PRIMARY + "Selects the clipboard `elfeed-search-yank' should use. +Choices are the symbols PRIMARY, SECONDARY, or CLIPBOARD." + :group 'elfeed + :type '(choice (const PRIMARY) (const SECONDARY) (const CLIPBOARD))) + +(defcustom elfeed-search-date-format '("%Y-%m-%d" 10 :left) + "The `format-time-string' format, target width, and alignment for dates. + +This should be (string integer keyword) for (format width alignment). +Possible alignments are :left and :right." + :group 'elfeed + :type '(list string integer (choice (const :left) (const :right)))) + +(defcustom elfeed-search-compile-filter t + "If non-nil, compile search filters into bytecode on the fly." + :group 'elfeed + :type 'boolean) + +(defvar elfeed-search-filter-active nil + "When non-nil, Elfeed is currently reading a filter from the minibuffer. +When live editing the filter, it is bound to :live.") + +(defvar elfeed-search-filter-overflowing nil + "When non-nil, the current live filter overflows the window.") + +(defvar elfeed-search--offset 1 + "Offset between line numbers and entry list position.") + +(defvar elfeed-search-header-function #'elfeed-search--header + "Function that returns the string to be used for the Elfeed search header.") + +(defvar elfeed-search-print-entry-function #'elfeed-search-print-entry--default + "Function to print entries into the *elfeed-search* buffer.") + +(defalias 'elfeed-search-tag-all-unread + (elfeed-expose #'elfeed-search-tag-all 'unread) + "Add the `unread' tag to all selected entries.") + +(defalias 'elfeed-search-untag-all-unread + (elfeed-expose #'elfeed-search-untag-all 'unread) + "Remove the `unread' tag from all selected entries.") + +(defalias 'elfeed-search-update--force + (elfeed-expose #'elfeed-search-update :force) + "Force refresh view of the feed listing.") + +(defun elfeed-search-quit-window () + "Save the database, then `quit-window'." + (interactive) + (elfeed-db-save) + (quit-window)) + +(defun elfeed-search-last-entry () + "Place point on last entry." + (interactive) + (goto-char (point-max)) + (forward-line -1)) + +(defun elfeed-search-first-entry () + "Place point on first entry." + (interactive) + (goto-char (point-min))) + +(defvar elfeed-search-mode-map + (let ((map (make-sparse-keymap))) + (prog1 map + (suppress-keymap map) + (define-key map "h" #'describe-mode) + (define-key map "q" #'elfeed-search-quit-window) + (define-key map "g" #'elfeed-search-update--force) + (define-key map "G" #'elfeed-search-fetch) + (define-key map (kbd "RET") #'elfeed-search-show-entry) + (define-key map "s" #'elfeed-search-live-filter) + (define-key map "S" #'elfeed-search-set-filter) + (define-key map "c" #'elfeed-search-clear-filter) + (define-key map "b" #'elfeed-search-browse-url) + (define-key map "y" #'elfeed-search-yank) + (define-key map "u" #'elfeed-search-tag-all-unread) + (define-key map "r" #'elfeed-search-untag-all-unread) + (define-key map "n" #'next-line) + (define-key map "p" #'previous-line) + (define-key map "+" #'elfeed-search-tag-all) + (define-key map "-" #'elfeed-search-untag-all) + (define-key map "<" #'elfeed-search-first-entry) + (define-key map ">" #'elfeed-search-last-entry))) + "Keymap for elfeed-search-mode.") + +(defun elfeed-search--intro-header () + "Return the header shown to new users." + (with-temp-buffer + (cl-flet ((button (f) + (insert-button (symbol-name f) + 'follow-link t + 'action (lambda (_) (call-interactively f))))) + (insert "Database empty. Use ") + (button 'elfeed-add-feed) + (insert ", or ") + (button 'elfeed-load-opml) + (insert ", or ") + (button 'elfeed-update) + (insert ".") + (buffer-string)))) + +(defun elfeed-search--count-unread () + "Count the number of entries and feeds being currently displayed." + (if (and elfeed-search-filter-active elfeed-search-filter-overflowing) + "?/?:?" + (cl-loop with feeds = (make-hash-table :test 'equal) + for entry in elfeed-search-entries + for feed = (elfeed-entry-feed entry) + for url = (elfeed-feed-url feed) + count entry into entry-count + count (elfeed-tagged-p 'unread entry) into unread-count + do (puthash url t feeds) + finally + (cl-return + (format "%d/%d:%d" + unread-count entry-count + (hash-table-count feeds)))))) + +(defun elfeed-search--header () + "Computes the string to be used as the Elfeed header." + (cond + ((zerop (elfeed-db-last-update)) + (elfeed-search--intro-header)) + ((> (elfeed-queue-count-total) 0) + (let ((total (elfeed-queue-count-total)) + (in-process (elfeed-queue-count-active))) + (format "%d jobs pending, %d active..." + (- total in-process) in-process))) + ((let* ((db-time (seconds-to-time (elfeed-db-last-update))) + (update (format-time-string "%Y-%m-%d %H:%M" db-time)) + (unread (elfeed-search--count-unread))) + (format "Updated %s, %s%s" + (propertize update 'face 'elfeed-search-last-update-face) + (propertize unread 'face 'elfeed-search-unread-count-face) + (cond + (elfeed-search-filter-active "") + ((string-match-p "[^ ]" elfeed-search-filter) + (concat ", " (propertize elfeed-search-filter + 'face 'elfeed-search-filter-face))) + (""))))))) + +(defun elfeed-search-mode () + "Major mode for listing elfeed feed entries. +\\{elfeed-search-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map elfeed-search-mode-map) + (setq major-mode 'elfeed-search-mode + mode-name "elfeed-search" + truncate-lines t + buffer-read-only t + desktop-save-buffer #'elfeed-search-desktop-save + ;; Provide format string via symbol value slot so that it will + ;; not be %-construct interpolated. The symbol is uninterned + ;; so that it's not *really* a global variable. + header-line-format + (let ((symbol (make-symbol "dummy"))) + (put symbol 'risky-local-variable t) + `(:eval + (prog1 ',symbol + (set ',symbol (funcall elfeed-search-header-function)))))) + (set (make-local-variable 'bookmark-make-record-function) + #'elfeed-search-bookmark-make-record) + (buffer-disable-undo) + (hl-line-mode) + (make-local-variable 'elfeed-search-entries) + (make-local-variable 'elfeed-search-filter) + (add-hook 'elfeed-update-hooks #'elfeed-search-update) + (add-hook 'elfeed-update-init-hooks #'elfeed-search-update--force) + (add-hook 'kill-buffer-hook #'elfeed-db-save t t) + (add-hook 'elfeed-db-unload-hook #'elfeed-search--unload) + (elfeed-search-update :force) + (run-mode-hooks 'elfeed-search-mode-hook)) + +(defun elfeed-search-buffer () + (get-buffer-create "*elfeed-search*")) + +(defun elfeed-search--unload () + "Hook function for `elfeed-db-unload-hook'." + (with-current-buffer (elfeed-search-buffer) + ;; don't try to save the database in this case + (remove-hook 'kill-buffer-hook #'elfeed-db-save t) + (kill-buffer ))) + +(defun elfeed-search-format-date (date) + "Format a date for printing in `elfeed-search-mode'. +The customization `elfeed-search-date-format' sets the formatting." + (cl-destructuring-bind (format target alignment) elfeed-search-date-format + (let* ((string (format-time-string format (seconds-to-time date))) + (width (string-width string))) + (cond + ((> width target) + (if (eq alignment :left) + (substring string 0 target) + (substring string (- width target) width))) + ((< width target) + (let ((pad (make-string (- target width) ?\s))) + (if (eq alignment :left) + (concat string pad) + (concat pad string)))) + (string))))) + +(defface elfeed-search-date-face + '((((class color) (background light)) (:foreground "#aaa")) + (((class color) (background dark)) (:foreground "#77a"))) + "Face used in search mode for dates." + :group 'elfeed) + +(defface elfeed-search-title-face + '((((class color) (background light)) (:foreground "#000")) + (((class color) (background dark)) (:foreground "#fff"))) + "Face used in search mode for titles." + :group 'elfeed) + +(defface elfeed-search-unread-title-face + '((t :weight bold)) + "Face used in search mode for unread entry titles." + :group 'elfeed) + +(defface elfeed-search-feed-face + '((((class color) (background light)) (:foreground "#aa0")) + (((class color) (background dark)) (:foreground "#ff0"))) + "Face used in search mode for feed titles." + :group 'elfeed) + +(defface elfeed-search-tag-face + '((((class color) (background light)) (:foreground "#070")) + (((class color) (background dark)) (:foreground "#0f0"))) + "Face used in search mode for tags." + :group 'elfeed) + +(defface elfeed-search-last-update-face + '((t)) + "Face for showing the date and time the database was last updated." + :group 'elfeed) + +(defface elfeed-search-unread-count-face + '((((class color) (background light)) (:foreground "#000")) + (((class color) (background dark)) (:foreground "#fff"))) + "Face used in search mode for unread entry titles." + :group 'elfeed) + +(defface elfeed-search-filter-face + '((t :inherit mode-line-buffer-id)) + "Face for showing the current Elfeed search filter." + :group 'elfeed) + +(defcustom elfeed-search-title-max-width 70 + "Maximum column width for titles in the elfeed-search buffer." + :group 'elfeed + :type 'integer) + +(defcustom elfeed-search-title-min-width 16 + "Minimum column width for titles in the elfeed-search buffer." + :group 'elfeed + :type 'integer) + +(defcustom elfeed-search-trailing-width 30 + "Space reserved for displaying the feed and tag information." + :group 'elfeed + :type 'integer) + +(defcustom elfeed-search-face-alist + '((unread elfeed-search-unread-title-face)) + "Mapping of tags to faces in the Elfeed entry listing." + :group 'elfeed + :type '(alist :key-type symbol :value-type (repeat face))) + +(defun elfeed-search--faces (tags) + "Return all the faces that apply to an entry with TAGS." + (nconc (cl-loop for (tag . faces) in elfeed-search-face-alist + when (memq tag tags) + append faces) + (list 'elfeed-search-title-face))) + +(defun elfeed-search-print-entry--default (entry) + "Print ENTRY to the buffer." + (let* ((date (elfeed-search-format-date (elfeed-entry-date entry))) + (title (or (elfeed-meta entry :title) (elfeed-entry-title entry) "")) + (title-faces (elfeed-search--faces (elfeed-entry-tags entry))) + (feed (elfeed-entry-feed entry)) + (feed-title + (when feed + (or (elfeed-meta feed :title) (elfeed-feed-title feed)))) + (tags (mapcar #'symbol-name (elfeed-entry-tags entry))) + (tags-str (mapconcat + (lambda (s) (propertize s 'face 'elfeed-search-tag-face)) + tags ",")) + (title-width (- (window-width) 10 elfeed-search-trailing-width)) + (title-column (elfeed-format-column + title (elfeed-clamp + elfeed-search-title-min-width + title-width + elfeed-search-title-max-width) + :left))) + (insert (propertize date 'face 'elfeed-search-date-face) " ") + (insert (propertize title-column 'face title-faces 'kbd-help title) " ") + (when feed-title + (insert (propertize feed-title 'face 'elfeed-search-feed-face) " ")) + (when tags + (insert "(" tags-str ")")))) + +(defun elfeed-search-parse-filter (filter) + "Parse the elements of a search filter into a plist." + (let ((must-have ()) + (must-not-have ()) + (before nil) + (after nil) + (matches ()) + (not-matches ()) + (limit nil) + (feeds ()) + (not-feeds ())) + (cl-loop for element in (split-string filter) + for type = (aref element 0) + do (cl-case type + (?+ + (let ((symbol (intern (substring element 1)))) + (unless (eq '## symbol) + (push symbol must-have)))) + (?- + (let ((symbol (intern (substring element 1)))) + (unless (eq '## symbol) + (push symbol must-not-have)))) + (?@ (cl-multiple-value-bind (a b) + (split-string (substring element 1) "--") + (let ((duration-a (elfeed-time-duration a)) + (duration-b (and b (elfeed-time-duration b)))) + (when (and duration-b (> duration-b duration-a)) + (cl-rotatef duration-a duration-b)) + (when duration-b (setf before duration-b)) + (setf after duration-a)))) + (?! (let ((re (substring element 1))) + (when (elfeed-valid-regexp-p re) + (push re not-matches)))) + (?# (setf limit (string-to-number (substring element 1)))) + (?= (let ((re (substring element 1))) + (when (elfeed-valid-regexp-p re) + (push re feeds)))) + (?~ (let ((re (substring element 1))) + (when (elfeed-valid-regexp-p re) + (push re not-feeds)))) + (otherwise (when (elfeed-valid-regexp-p element) + (push element matches))))) + `(,@(when before + (list :before before)) + ,@(when after + (list :after after)) + ,@(when must-have + (list :must-have must-have)) + ,@(when must-not-have + (list :must-not-have must-not-have)) + ,@(when matches + (list :matches matches)) + ,@(when not-matches + (list :not-matches not-matches)) + ,@(when limit + (list :limit limit)) + ,@(when feeds + (list :feeds feeds)) + ,@(when not-feeds + (list :not-feeds not-feeds))))) + +(defun elfeed-search--recover-time (seconds) + "Pick a reasonable filter representation for SECONDS." + (let ((units '((60 1 "minute") + (60 1 "hour") + (24 1 "day") + (7 1 "week") + (30 7 "month") + (1461 120 "year"))) + (value (float seconds)) + (name "second")) + (cl-loop for (n d unit) in units + for next-value = (/ (* value d) n) + when (< next-value 1.0) + return t + do (setf name unit + value next-value)) + (let ((count (format "%.4g" value))) + (format "%s-%s%s-ago" count name (if (equal count "1") "" "s"))))) + +(defun elfeed-search--recover-units (after-seconds &optional before-seconds) + "Stringify the age or optionally the date range specified by +AFTER-SECONDS and BEFORE-SECONDS." + (apply 'concat "@" + (elfeed-search--recover-time after-seconds) + (when before-seconds + (list "--"(elfeed-search--recover-time before-seconds))))) + +(defun elfeed-search-unparse-filter (filter) + "Inverse of `elfeed-search-parse-filter', returning a string. + +The time (@n-units-ago) filter may not exactly match the +original, but will be equal in its effect." + (let ((output ())) + (cl-destructuring-bind (&key after before + must-have must-not-have + matches not-matches + feeds not-feeds + limit &allow-other-keys) + filter + (when after + (push (elfeed-search--recover-units after before) output)) + (dolist (tag must-have) + (push (format "+%S" tag) output)) + (dolist (tag must-not-have) + (push (format "-%S" tag) output)) + (dolist (re matches) + (push re output)) + (dolist (re not-matches) + (push (concat "!" re) output)) + (when limit + (push (format "#%d" limit) output)) + (dolist (feed feeds) + (push (format "=%s" feed) output)) + (dolist (feed not-feeds) + (push (format "~%s" feed) output)) + (mapconcat #'identity (nreverse output) " ")))) + +(defun elfeed-search-filter (filter entry feed &optional count) + "Return non-nil if ENTRY and FEED pass FILTER. + +COUNT is the total number of entries collected so far, for +filtering against a limit filter (ex. #10). + +See `elfeed-search-set-filter' for format/syntax documentation. +This function must *only* be called within the body of +`with-elfeed-db-visit' because it may perform a non-local exit." + (cl-destructuring-bind (&key must-have must-not-have + matches not-matches + feeds not-feeds + after limit &allow-other-keys) + filter + (let* ((tags (elfeed-entry-tags entry)) + (date (elfeed-entry-date entry)) + (age (- (float-time) date)) + (title (or (elfeed-meta entry :title) (elfeed-entry-title entry))) + (link (elfeed-entry-link entry)) + (feed-title + (or (elfeed-meta feed :title) (elfeed-feed-title feed) "")) + (feed-id (elfeed-feed-id feed))) + (when (or (and after (> age after)) + (and limit (<= limit 0)) + (and limit count (>= count limit))) + (elfeed-db-return)) + (and (cl-every (lambda (tag) (memq tag tags)) must-have) + (cl-notany (lambda (tag) (memq tag tags)) must-not-have) + (or (null matches) + (cl-every + (lambda (m) + (or (and title (string-match-p m title)) + (and link (string-match-p m link)))) + matches)) + (cl-notany (lambda (m) + (or (and title (string-match-p m title)) + (and link (string-match-p m link)))) + not-matches) + (or (null feeds) + (cl-some (lambda (f) + (or (string-match-p f feed-id) + (string-match-p f feed-title))) + feeds)) + (cl-notany (lambda (f) + (or (string-match-p f feed-id) + (string-match-p f feed-title))) + not-feeds))))) + +(defun elfeed-search-compile-filter (filter) + "Compile FILTER into a lambda function for `byte-compile'. + +Executing a filter in bytecode form is generally faster than +\"interpreting\" the filter with `elfeed-search-filter'." + (cl-destructuring-bind (&key after before + must-have must-not-have + matches not-matches + feeds not-feeds + limit &allow-other-keys) + filter + `(lambda (,(if (or after matches not-matches must-have must-not-have) + 'entry + '_entry) + ,(if (or feeds not-feeds) + 'feed + '_feed) + ,(if limit + 'count + '_count)) + (let* (,@(when after + '((date (elfeed-entry-date entry)) + (age (- (float-time) date)))) + ,@(when (or must-have must-not-have) + '((tags (elfeed-entry-tags entry)))) + ,@(when (or matches not-matches) + '((title (or (elfeed-meta entry :title) + (elfeed-entry-title entry))) + (link (elfeed-entry-link entry)))) + ,@(when (or feeds not-feeds) + '((feed-id (elfeed-feed-id feed)) + (feed-title (or (elfeed-meta feed :title) + (elfeed-feed-title feed) ""))))) + ,@(when after + `((when (> age ,after) + (elfeed-db-return)))) + ,@(when limit + `((when (>= count ,limit) + (elfeed-db-return)))) + (and ,@(cl-loop for forbid in must-not-have + collect `(not (memq ',forbid tags))) + ,@(cl-loop for forbid in must-have + collect `(memq ',forbid tags)) + ,@(cl-loop for regex in matches collect + `(or (string-match-p ,regex title) + (string-match-p ,regex link))) + ,@(cl-loop for regex in not-matches collect + `(not + (or (string-match-p ,regex title) + (string-match-p ,regex link)))) + ,@(when feeds + `((or ,@(cl-loop + for regex in feeds + collect `(string-match-p ,regex feed-id) + collect `(string-match-p ,regex feed-title))))) + ,@(when not-feeds + `((not + (or ,@(cl-loop + for regex in not-feeds + collect `(string-match-p ,regex feed-id) + collect `(string-match-p ,regex feed-title)))))) + ,@(when before + `((> age ,before)))))))) + +(defun elfeed-search--prompt (current) + "Prompt for a new filter, starting with CURRENT." + (read-from-minibuffer + "Filter: " + (if (or (string= "" current) + (string-match-p " $" current)) + current + (concat current " ")) + nil nil 'elfeed-search-filter-history)) + +(defun elfeed-search-clear-filter () + "Reset the search filter to the default value of `elfeed-search-filter'." + (interactive) + (setf elfeed-search-filter (default-value 'elfeed-search-filter)) + (elfeed-search-update--force)) + +(defun elfeed-search-set-filter (new-filter) + "Set a new search filter for the elfeed-search buffer. + +When NEW-FILTER is nil, reset the filter to the default value. + +When given a prefix argument, the current filter is not displayed +in the minibuffer when prompting for a new filter. + +Any component beginning with a + or - is treated as a tag. If + +the tag must be present on the entry. If - the tag must *not* be +present on the entry. Ex. \"+unread\" or \"+unread -comic\". + +Any component beginning with an @ is an age limit or an age +range. If a limit, no posts older than this are allowed. If a +range, posts dates have to be inbetween the specified date +range. Examples: +- \"@3-days-ago\" +- \"@1-year-old\" +- \"@2019-06-24\" +- \"@2019-06-24--2019-06-24\" +- \"@5-days-ago--1-day-ago\" + +Any component beginning with a # is an entry count maximum. The +number following # determines the maxiumum number of entries +to be shown (descending by date). Ex. \"#20\" or \"#100\". + +Any component beginning with a = is a regular expression matching +the entry's feed (title or URL). Only entries belonging to a feed +that match at least one of the = expressions will be shown. + +Every other space-seperated element is treated like a regular +expression, matching against entry link, title, and feed title." + (interactive + (let ((elfeed-search-filter-active :non-interactive)) + (list (elfeed-search--prompt + (if current-prefix-arg "" elfeed-search-filter))))) + (with-current-buffer (elfeed-search-buffer) + (setf elfeed-search-filter + (or new-filter (default-value 'elfeed-search-filter))) + (elfeed-search-update :force))) + +(defun elfeed-search--update-list () + "Update `elfeed-search-filter' list." + (let* ((filter (elfeed-search-parse-filter elfeed-search-filter)) + (head (list nil)) + (tail head) + (count 0)) + (if elfeed-search-compile-filter + ;; Force lexical bindings regardless of the current + ;; buffer-local value. Lexical scope uses the faster + ;; stack-ref opcode instead of the traditional varref opcode. + (let ((lexical-binding t) + (func (byte-compile (elfeed-search-compile-filter filter)))) + (with-elfeed-db-visit (entry feed) + (when (funcall func entry feed count) + (setf (cdr tail) (list entry) + tail (cdr tail) + count (1+ count))))) + (with-elfeed-db-visit (entry feed) + (when (elfeed-search-filter filter entry feed count) + (setf (cdr tail) (list entry) + tail (cdr tail) + count (1+ count))))) + ;; Determine the final list order + (let ((entries (cdr head))) + (when elfeed-search-sort-function + (setf entries (sort entries elfeed-search-sort-function))) + (when (eq elfeed-sort-order 'ascending) + (setf entries (nreverse entries))) + (setf elfeed-search-entries + entries)))) + +(defmacro elfeed-save-excursion (&rest body) + "Like `save-excursion', but by entry/line/column instead of point." + (declare (indent defun)) + `(let ((entry (elfeed-search-selected :single)) + (line (line-number-at-pos)) + (column (current-column))) + (unwind-protect + (progn ,@body) + (let ((entry-position (cl-position entry elfeed-search-entries))) + (elfeed-goto-line (if entry-position + (+ elfeed-search--offset entry-position) + line)) + (move-to-column column))))) + +(defun elfeed-search-update (&optional force) + "Update the elfeed-search buffer listing to match the database. +When FORCE is non-nil, redraw even when the database hasn't changed." + (interactive) + (with-current-buffer (elfeed-search-buffer) + (when (or force (and (not elfeed-search-filter-active) + (< elfeed-search-last-update (elfeed-db-last-update)))) + (elfeed-save-excursion + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + (elfeed-search--update-list) + (dolist (entry elfeed-search-entries) + (funcall elfeed-search-print-entry-function entry) + (insert "\n")) + (setf elfeed-search-last-update (float-time)))) + (when (zerop (buffer-size)) + ;; If nothing changed, force a header line update + (force-mode-line-update)) + (run-hooks 'elfeed-search-update-hook)))) + +(defun elfeed-search-fetch (prefix) + "Update all feeds via `elfeed-update', or only visible feeds with PREFIX. +Given a prefix, this function becomes `elfeed-search-fetch-visible'." + (interactive "P") + (if prefix + (elfeed-search-fetch-visible) + (elfeed-update))) + +(defun elfeed-search-fetch-visible () + "Update any feed with an entry currently displayed in the search buffer." + (interactive) + (cl-loop with seen = (make-hash-table :test 'equal) + for entry in elfeed-search-entries + for feed = (elfeed-entry-feed entry) + for url = (elfeed-feed-url feed) + when (not (gethash url seen)) + do (elfeed-update-feed (setf (gethash url seen) url)))) + +(defun elfeed-search-update-line (&optional n) + "Redraw the current line." + (let ((inhibit-read-only t)) + (save-excursion + (when n (elfeed-goto-line n)) + (let ((entry (elfeed-search-selected :ignore-region))) + (when entry + (elfeed-kill-line) + (funcall elfeed-search-print-entry-function entry)))))) + +(defun elfeed-search-update-entry (entry) + "Redraw a specific entry." + (let ((n (cl-position entry elfeed-search-entries))) + (when n (elfeed-search-update-line (+ elfeed-search--offset n))))) + +(defun elfeed-search-selected (&optional ignore-region-p) + "Return a list of the currently selected feeds. + +If IGNORE-REGION-P is non-nil, only return the entry under point." + (let ((use-region (and (not ignore-region-p) (use-region-p)))) + (let ((start (if use-region (region-beginning) (point))) + (end (if use-region (region-end) (point)))) + (cl-loop for line from (line-number-at-pos start) + to (line-number-at-pos end) + for offset = (- line elfeed-search--offset) + when (and (>= offset 0) (nth offset elfeed-search-entries)) + collect it into selected + finally (return (if ignore-region-p + (car selected) + selected)))))) + +(defun elfeed-search-browse-url (&optional use-generic-p) + "Visit the current entry in your browser using `browse-url'. +If there is a prefix argument, visit the current entry in the +browser defined by `browse-url-generic-program'." + (interactive "P") + (let ((buffer (current-buffer)) + (entries (elfeed-search-selected))) + (cl-loop for entry in entries + do (elfeed-untag entry 'unread) + when (elfeed-entry-link entry) + do (if use-generic-p + (browse-url-generic it) + (browse-url it))) + ;; `browse-url' could have switched to another buffer if eww or another + ;; internal browser is used, but the remainder of the functions needs to + ;; run in the elfeed buffer. + (with-current-buffer buffer + (mapc #'elfeed-search-update-entry entries) + (unless (or elfeed-search-remain-on-entry (use-region-p)) + (forward-line))))) + +(defun elfeed-search-yank () + "Copy the selected feed items to clipboard and kill-ring." + (interactive) + (let* ((entries (elfeed-search-selected)) + (links (mapcar #'elfeed-entry-link entries)) + (links-str (mapconcat #'identity links " "))) + (when entries + (elfeed-untag entries 'unread) + (kill-new links-str) + (if (fboundp 'gui-set-selection) + (gui-set-selection elfeed-search-clipboard-type links-str) + (with-no-warnings + (x-set-selection elfeed-search-clipboard-type links-str))) + (message "Copied: %s" links-str) + (mapc #'elfeed-search-update-entry entries) + (unless (or elfeed-search-remain-on-entry (use-region-p)) + (forward-line))))) + +(defun elfeed-search-tag-all (tag) + "Apply TAG to all selected entries." + (interactive (list (intern (read-from-minibuffer "Tag: ")))) + (let ((entries (elfeed-search-selected))) + (elfeed-tag entries tag) + (mapc #'elfeed-search-update-entry entries) + (unless (or elfeed-search-remain-on-entry (use-region-p)) + (forward-line)))) + +(defun elfeed-search-untag-all (tag) + "Remove TAG from all selected entries." + (interactive (list (intern (read-from-minibuffer "Tag: ")))) + (let ((entries (elfeed-search-selected))) + (elfeed-untag entries tag) + (mapc #'elfeed-search-update-entry entries) + (unless (or elfeed-search-remain-on-entry (use-region-p)) + (forward-line)))) + +(defun elfeed-search-toggle-all (tag) + "Toggle TAG on all selected entries." + (interactive (list (intern (read-from-minibuffer "Tag: ")))) + (let ((entries (elfeed-search-selected)) entries-tag entries-untag) + (cl-loop for entry in entries + when (elfeed-tagged-p tag entry) + do (push entry entries-untag) + else do (push entry entries-tag)) + (elfeed-tag entries-tag tag) + (elfeed-untag entries-untag tag) + (mapc #'elfeed-search-update-entry entries) + (unless (or elfeed-search-remain-on-entry (use-region-p)) + (forward-line)))) + +(defun elfeed-search-show-entry (entry) + "Display the currently selected item in a buffer." + (interactive (list (elfeed-search-selected :ignore-region))) + (require 'elfeed-show) + (when (elfeed-entry-p entry) + (elfeed-untag entry 'unread) + (elfeed-search-update-entry entry) + (unless elfeed-search-remain-on-entry (forward-line)) + (elfeed-show-entry entry))) + +(defun elfeed-search-set-entry-title (title) + "Manually set the title for the entry under point. +Sets the :title key of the entry's metadata. See `elfeed-meta'." + (interactive "sTitle: ") + (let ((entry (elfeed-search-selected :ignore-region))) + (unless entry + (error "No entry selected!")) + (setf (elfeed-meta entry :title) title) + (elfeed-search-update-entry entry))) + +(defun elfeed-search-set-feed-title (title) + "Manually set the title for the feed belonging to the entry under point. +Sets the :title key of the feed's metadata. See `elfeed-meta'." + (interactive "sTitle: ") + (let ((entry (elfeed-search-selected :ignore-region))) + (unless entry + (error "No entry selected!")) + (let ((feed (elfeed-entry-feed entry))) + (setf (elfeed-meta feed :title) title) + (dolist (to-fix elfeed-search-entries) + (elfeed-search-update-entry to-fix))))) + +;; Live Filters + +(defvar elfeed-search-filter-syntax-table + (let ((table (make-syntax-table))) + (prog1 table + (modify-syntax-entry ?+ "w" table) + (modify-syntax-entry ?- "w" table) + (modify-syntax-entry ?= "w" table) + (modify-syntax-entry ?@ "w" table))) + "Syntax table active when editing the filter in the minibuffer.") + +(defun elfeed-search--minibuffer-setup () + "Set up the minibuffer for live filtering." + (when elfeed-search-filter-active + (set-syntax-table elfeed-search-filter-syntax-table) + (when (eq :live elfeed-search-filter-active) + (add-hook 'post-command-hook 'elfeed-search--live-update nil :local)))) + +(add-hook 'minibuffer-setup-hook 'elfeed-search--minibuffer-setup) + +(defun elfeed-search--live-update () + "Update the elfeed-search buffer based on the contents of the minibuffer." + (when (eq :live elfeed-search-filter-active) + (let ((buffer (elfeed-search-buffer)) + (current-filter (minibuffer-contents-no-properties))) + (when buffer + (with-current-buffer buffer + (let* ((window (get-buffer-window (elfeed-search-buffer))) + (height (window-total-height window)) + (limiter (if window + (format "#%d " height) + "#1 ")) + (elfeed-search-filter (concat limiter current-filter))) + (elfeed-search-update :force) + (setf elfeed-search-filter-overflowing + (= (length elfeed-search-entries) + height)))))))) + +(defun elfeed-search-live-filter () + "Filter the elfeed-search buffer as the filter is written." + (interactive) + (unwind-protect + (let ((elfeed-search-filter-active :live)) + (setq elfeed-search-filter + (read-from-minibuffer "Filter: " elfeed-search-filter))) + (elfeed-search-update :force))) + +;; Bookmarks + +;;;###autoload +(defun elfeed-search-bookmark-handler (record) + "Jump to an elfeed-search bookmarked location." + (elfeed) + (elfeed-search-set-filter (bookmark-prop-get record 'location))) + +(defun elfeed-search-bookmark-make-record () + "Return a bookmark record for the current elfeed-search buffer." + (let* ((filter (elfeed-search-parse-filter elfeed-search-filter)) + (tags (plist-get filter :must-have))) + `(,(format "elfeed %s" elfeed-search-filter) + (location . ,elfeed-search-filter) + (tags ,@(mapcar #'symbol-name tags)) + (handler . elfeed-search-bookmark-handler)))) + +;; Desktop Save + +(defun elfeed-search-desktop-save (_desktop-dirname) + "Save the state of the current elfeed-search buffer so that it + may be restored as part of a saved desktop. Also save the state + of the db for when `desktop-auto-save-timeout' is enabled." + (elfeed-db-save) + elfeed-search-filter) + +;;;###autoload +(defun elfeed-search-desktop-restore (_file-name _buffer-name search-filter) + "Restore the state of an elfeed-search buffer on desktop restore." + (elfeed) + (elfeed-search-set-filter search-filter) + (current-buffer)) + +;;;###autoload +(add-to-list 'desktop-buffer-mode-handlers + '(elfeed-search-mode . elfeed-search-desktop-restore)) + +(provide 'elfeed-search) + +;;; elfeed-search.el ends here blob - /dev/null blob + 4915cae4d5a0e3046f0fb92986a5e4019003be8d (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed-show.el @@ -0,0 +1,500 @@ +;;; elfeed-show.el --- display feed entries -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;;; Code: + +(require 'cl-lib) +(require 'shr) +(require 'url-parse) +(require 'browse-url) +(require 'message) ; faces +(require 'bookmark) +(bookmark-maybe-load-default-file) + +(require 'elfeed) +(require 'elfeed-db) +(require 'elfeed-lib) +(require 'elfeed-search) + +(defcustom elfeed-show-truncate-long-urls t + "When non-nil, use an ellipsis to shorten very long displayed URLs." + :group 'elfeed + :type 'boolean) + +(defcustom elfeed-show-entry-author t + "When non-nil, show the entry's author (if it's in the entry's metadata)." + :group 'elfeed + :type 'boolean) + +(defvar elfeed-show-entry nil + "The entry being displayed in this buffer.") + +(defcustom elfeed-show-entry-switch #'switch-to-buffer + "Function used to display the feed entry buffer." + :group 'elfeed + :type '(choice (function-item switch-to-buffer) + (function-item pop-to-buffer) + function)) + +(defcustom elfeed-show-entry-delete #'elfeed-kill-buffer + "Function called when quitting from the elfeed-entry buffer. +Called without arguments." + :group 'elfeed + :type '(choice (function-item elfeed-kill-buffer) + (function-item delete-window) + function)) + +(defvar elfeed-show-refresh-function #'elfeed-show-refresh--mail-style + "Function called to refresh the `*elfeed-entry*' buffer.") + +(defvar elfeed-show-mode-map + (let ((map (make-sparse-keymap))) + (prog1 map + (suppress-keymap map) + (define-key map "h" #'describe-mode) + (define-key map "d" #'elfeed-show-save-enclosure) + (define-key map "q" #'elfeed-kill-buffer) + (define-key map "g" #'elfeed-show-refresh) + (define-key map "n" #'elfeed-show-next) + (define-key map "p" #'elfeed-show-prev) + (define-key map "s" #'elfeed-show-new-live-search) + (define-key map "b" #'elfeed-show-visit) + (define-key map "y" #'elfeed-show-yank) + (define-key map "u" #'elfeed-show-tag--unread) + (define-key map "+" #'elfeed-show-tag) + (define-key map "-" #'elfeed-show-untag) + (define-key map "<" #'beginning-of-buffer) + (define-key map ">" #'end-of-buffer) + (define-key map (kbd "SPC") #'scroll-up-command) + (define-key map (kbd "DEL") #'scroll-down-command) + (define-key map (kbd "TAB") #'elfeed-show-next-link) + (define-key map "\e\t" #'shr-previous-link) + (define-key map [backtab] #'shr-previous-link) + (define-key map "c" #'elfeed-kill-link-url-at-point) + (define-key map [mouse-2] #'shr-browse-url) + (define-key map "A" #'elfeed-show-add-enclosure-to-playlist) + (define-key map "P" #'elfeed-show-play-enclosure))) + "Keymap for `elfeed-show-mode'.") + +(defun elfeed-show-mode () + "Mode for displaying Elfeed feed entries. +\\{elfeed-show-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map elfeed-show-mode-map) + (setq major-mode 'elfeed-show-mode + mode-name "elfeed-show" + buffer-read-only t) + (buffer-disable-undo) + (make-local-variable 'elfeed-show-entry) + (set (make-local-variable 'bookmark-make-record-function) + #'elfeed-show-bookmark-make-record) + (run-mode-hooks 'elfeed-show-mode-hook)) + +(defalias 'elfeed-show-tag--unread + (elfeed-expose #'elfeed-show-tag 'unread) + "Mark the current entry unread.") + +(defun elfeed-insert-html (html &optional base-url) + "Converted HTML markup to a propertized string." + (shr-insert-document + (if (elfeed-libxml-supported-p) + (with-temp-buffer + ;; insert to work around libxml-parse-html-region bug + (when base-url + (insert (format "" base-url))) + (insert html) + (libxml-parse-html-region (point-min) (point-max) base-url)) + '(i () "Elfeed: libxml2 functionality is unavailable")))) + +(cl-defun elfeed-insert-link (url &optional (content url)) + "Insert a clickable hyperlink to URL titled CONTENT." + (when (and elfeed-show-truncate-long-urls + (integerp shr-width) + (> (length content) (- shr-width 8))) + (let ((len (- (/ shr-width 2) 10))) + (setq content (format "%s[...]%s" + (substring content 0 len) + (substring content (- len)))))) + (elfeed-insert-html (format "%s" url content))) + +(defun elfeed-compute-base (url) + "Return the base URL for URL, useful for relative paths." + (let ((obj (url-generic-parse-url url))) + (setf (url-filename obj) nil) + (setf (url-target obj) nil) + (url-recreate-url obj))) + +(defun elfeed--show-format-author (author) + "Format author plist for the header." + (cl-destructuring-bind (&key name uri email &allow-other-keys) + author + (cond ((and name uri email) + (format "%s <%s> (%s)" name email uri)) + ((and name email) + (format "%s <%s>" name email)) + ((and name uri) + (format "%s (%s)" name uri)) + (name name) + (email email) + (uri uri) + ("[unknown]")))) + +(defun elfeed-show-refresh--mail-style () + "Update the buffer to match the selected entry, using a mail-style." + (interactive) + (let* ((inhibit-read-only t) + (title (elfeed-entry-title elfeed-show-entry)) + (date (seconds-to-time (elfeed-entry-date elfeed-show-entry))) + (authors (elfeed-meta elfeed-show-entry :authors)) + (link (elfeed-entry-link elfeed-show-entry)) + (tags (elfeed-entry-tags elfeed-show-entry)) + (tagsstr (mapconcat #'symbol-name tags ", ")) + (nicedate (format-time-string "%a, %e %b %Y %T %Z" date)) + (content (elfeed-deref (elfeed-entry-content elfeed-show-entry))) + (type (elfeed-entry-content-type elfeed-show-entry)) + (feed (elfeed-entry-feed elfeed-show-entry)) + (feed-title (elfeed-feed-title feed)) + (base (and feed (elfeed-compute-base (elfeed-feed-url feed))))) + (erase-buffer) + (insert (format (propertize "Title: %s\n" 'face 'message-header-name) + (propertize title 'face 'message-header-subject))) + (when elfeed-show-entry-author + (dolist (author authors) + (let ((formatted (elfeed--show-format-author author))) + (insert + (format (propertize "Author: %s\n" 'face 'message-header-name) + (propertize formatted 'face 'message-header-to)))))) + (insert (format (propertize "Date: %s\n" 'face 'message-header-name) + (propertize nicedate 'face 'message-header-other))) + (insert (format (propertize "Feed: %s\n" 'face 'message-header-name) + (propertize feed-title 'face 'message-header-other))) + (when tags + (insert (format (propertize "Tags: %s\n" 'face 'message-header-name) + (propertize tagsstr 'face 'message-header-other)))) + (insert (propertize "Link: " 'face 'message-header-name)) + (elfeed-insert-link link link) + (insert "\n") + (cl-loop for enclosure in (elfeed-entry-enclosures elfeed-show-entry) + do (insert (propertize "Enclosure: " 'face 'message-header-name)) + do (elfeed-insert-link (car enclosure)) + do (insert "\n")) + (insert "\n") + (if content + (if (eq type 'html) + (elfeed-insert-html content base) + (insert content)) + (insert (propertize "(empty)\n" 'face 'italic))) + (goto-char (point-min)))) + +(defun elfeed-show-refresh () + "Update the buffer to match the selected entry." + (interactive) + (call-interactively elfeed-show-refresh-function)) + +(defcustom elfeed-show-unique-buffers nil + "When non-nil, every entry buffer gets a unique name. +This allows for displaying multiple show buffers at the same +time." + :group 'elfeed + :type 'boolean) + +(defun elfeed-show--buffer-name (entry) + "Return the appropriate buffer name for ENTRY. +The result depends on the value of `elfeed-show-unique-buffers'." + (if elfeed-show-unique-buffers + (format "*elfeed-entry-<%s %s>*" + (elfeed-entry-title entry) + (format-time-string "%F" (elfeed-entry-date entry))) + "*elfeed-entry*")) + +(defun elfeed-show-entry (entry) + "Display ENTRY in the current buffer." + (let ((buff (get-buffer-create (elfeed-show--buffer-name entry)))) + (with-current-buffer buff + (elfeed-show-mode) + (setq elfeed-show-entry entry) + (elfeed-show-refresh)) + (funcall elfeed-show-entry-switch buff))) + +(defun elfeed-show-next () + "Show the next item in the elfeed-search buffer." + (interactive) + (funcall elfeed-show-entry-delete) + (with-current-buffer (elfeed-search-buffer) + (when elfeed-search-remain-on-entry (forward-line 1)) + (call-interactively #'elfeed-search-show-entry))) + +(defun elfeed-show-prev () + "Show the previous item in the elfeed-search buffer." + (interactive) + (funcall elfeed-show-entry-delete) + (with-current-buffer (elfeed-search-buffer) + (when elfeed-search-remain-on-entry (forward-line 1)) + (forward-line -2) + (call-interactively #'elfeed-search-show-entry))) + +(defun elfeed-show-new-live-search () + "Kill the current buffer, search again in *elfeed-search*." + (interactive) + (elfeed-kill-buffer) + (elfeed) + (elfeed-search-live-filter)) + +(defun elfeed-show-visit (&optional use-generic-p) + "Visit the current entry in your browser using `browse-url'. +If there is a prefix argument, visit the current entry in the +browser defined by `browse-url-generic-program'." + (interactive "P") + (let ((link (elfeed-entry-link elfeed-show-entry))) + (when link + (message "Sent to browser: %s" link) + (if use-generic-p + (browse-url-generic link) + (browse-url link))))) + +(defun elfeed-show-yank () + "Copy the current entry link URL to the clipboard." + (interactive) + (let ((link (elfeed-entry-link elfeed-show-entry))) + (when link + (kill-new link) + (if (fboundp 'gui-set-selection) + (gui-set-selection 'PRIMARY link) + (with-no-warnings + (x-set-selection 'PRIMARY link))) + (message "Yanked: %s" link)))) + +(defun elfeed-show-tag (&rest tags) + "Add TAGS to the displayed entry." + (interactive (list (intern (read-from-minibuffer "Tag: ")))) + (let ((entry elfeed-show-entry)) + (apply #'elfeed-tag entry tags) + (with-current-buffer (elfeed-search-buffer) + (elfeed-search-update-entry entry)) + (elfeed-show-refresh))) + +(defun elfeed-show-untag (&rest tags) + "Remove TAGS from the displayed entry." + (interactive (let* ((tags (elfeed-entry-tags elfeed-show-entry)) + (names (mapcar #'symbol-name tags)) + (select (completing-read "Untag: " names nil :match))) + (list (intern select)))) + (let ((entry elfeed-show-entry)) + (apply #'elfeed-untag entry tags) + (with-current-buffer (elfeed-search-buffer) + (elfeed-search-update-entry entry)) + (elfeed-show-refresh))) + +;; Enclosures: + +(defcustom elfeed-enclosure-default-dir (expand-file-name "~") + "Default directory for saving enclosures. +This can be either a string (a file system path), or a function +that takes a filename and the mime-type as arguments, and returns +the enclosure dir." + :type 'directory + :group 'elfeed + :safe 'stringp) + +(defcustom elfeed-save-multiple-enclosures-without-asking nil + "If non-nil, saving multiple enclosures asks once for a +directory and saves all attachments in the chosen directory." + :type 'boolean + :group 'elfeed) + +(defvar elfeed-show-enclosure-filename-function + #'elfeed-show-enclosure-filename-remote + "Function called to generate the filename for an enclosure.") + +(defun elfeed--download-enclosure (url path) + "Download asynchronously the enclosure from URL to PATH." + (if (require 'async nil :noerror) + (with-no-warnings + (async-start + (lambda () + (url-copy-file url path t)) + (lambda (_) + (message (format "%s downloaded" url))))) + (url-copy-file url path t))) + +(defun elfeed--get-enclosure-num (prompt entry &optional multi) + "Ask the user with PROMPT for an enclosure number for ENTRY. +The number is [1..n] for enclosures \[0..(n-1)] in the entry. If +MULTI is nil, return the number for the enclosure; +otherwise (MULTI is non-nil), accept ranges of enclosure numbers, +as per `elfeed-split-ranges-to-numbers', and return the +corresponding string." + (let* ((count (length (elfeed-entry-enclosures entry))) + def) + (when (zerop count) + (error "No enclosures to this entry")) + (if (not multi) + (if (= count 1) + (read-number (format "%s: " prompt) 1) + (read-number (format "%s (1-%d): " prompt count))) + (progn + (setq def (if (= count 1) "1" (format "1-%d" count))) + (read-string (format "%s (default %s): " prompt def) + nil nil def))))) + +(defun elfeed--request-enclosure-path (fname path) + "Ask the user where to save FNAME (default is PATH/FNAME)." + (let ((fpath (expand-file-name + (read-file-name "Save as: " path nil nil fname) path))) + (if (file-directory-p fpath) + (expand-file-name fname fpath) + fpath))) + +(defun elfeed--request-enclosures-dir (path) + "Ask the user where to save multiple enclosures (default is PATH)." + (let ((fpath (expand-file-name + (read-directory-name + (format "Save in directory: ") path nil nil nil) path))) + (if (file-directory-p fpath) + fpath))) + +(defun elfeed-show-enclosure-filename-remote (_entry url-enclosure) + "Returns the remote filename as local filename for an enclosure." + (file-name-nondirectory + (url-unhex-string + (car (url-path-and-query (url-generic-parse-url + url-enclosure)))))) + +(defun elfeed-show-save-enclosure-single (&optional entry enclosure-index) + "Save enclosure number ENCLOSURE-INDEX from ENTRY. +If ENTRY is nil use the elfeed-show-entry variable. +If ENCLOSURE-INDEX is nil ask for the enclosure number." + (interactive) + (let* ((path elfeed-enclosure-default-dir) + (entry (or entry elfeed-show-entry)) + (enclosure-index (or enclosure-index + (elfeed--get-enclosure-num + "Enclosure to save" entry))) + (url-enclosure (car (elt (elfeed-entry-enclosures entry) + (- enclosure-index 1)))) + (fname + (funcall elfeed-show-enclosure-filename-function + entry url-enclosure)) + (retry t) + (fpath)) + (while retry + (setf fpath (elfeed--request-enclosure-path fname path) + retry (and (file-exists-p fpath) + (not (y-or-n-p (format "Overwrite '%s'?" fpath)))))) + (elfeed--download-enclosure url-enclosure fpath))) + +(defun elfeed-show-save-enclosure-multi (&optional entry) + "Offer to save multiple entry enclosures from the current entry. +Default is to save all enclosures, [1..n], where n is the number of +enclosures. You can type multiple values separated by space, e.g. + 1 3-6 8 +will save enclosures 1,3,4,5,6 and 8. + +Furthermore, there is a shortcut \"a\" which so means all +enclosures, but as this is the default, you may not need it." + (interactive) + (let* ((entry (or entry elfeed-show-entry)) + (attachstr (elfeed--get-enclosure-num + "Enclosure number range (or 'a' for 'all')" entry t)) + (count (length (elfeed-entry-enclosures entry))) + (attachnums (elfeed-split-ranges-to-numbers attachstr count)) + (path elfeed-enclosure-default-dir) + (fpath)) + (if elfeed-save-multiple-enclosures-without-asking + (let ((attachdir (elfeed--request-enclosures-dir path))) + (dolist (enclosure-index attachnums) + (let* ((url-enclosure + (aref (elfeed-entry-enclosures entry) enclosure-index)) + (fname + (funcall elfeed-show-enclosure-filename-function + entry url-enclosure)) + (retry t)) + (while retry + (setf fpath (expand-file-name (concat attachdir fname) path) + retry + (and (file-exists-p fpath) + (not (y-or-n-p (format "Overwrite '%s'?" fpath)))))) + (elfeed--download-enclosure url-enclosure fpath)))) + (dolist (enclosure-index attachnums) + (elfeed-show-save-enclosure-single entry enclosure-index))))) + +(defun elfeed-show-save-enclosure (&optional multi) + "Offer to save enclosure(s). +If MULTI (prefix-argument) is nil, save a single one, otherwise, +offer to save a range of enclosures." + (interactive "P") + (if multi + (elfeed-show-save-enclosure-multi) + (elfeed-show-save-enclosure-single))) + +(defun elfeed--enclosure-maybe-prompt-index (entry) + "Prompt for an enclosure if there are multiple in ENTRY." + (if (= 1 (length (elfeed-entry-enclosures entry))) + 1 + (elfeed--get-enclosure-num "Enclosure to play" entry))) + +(defun elfeed-show-play-enclosure (enclosure-index) + "Play enclosure number ENCLOSURE-INDEX from current entry using EMMS. +Prompts for ENCLOSURE-INDEX when called interactively." + (interactive (list (elfeed--enclosure-maybe-prompt-index elfeed-show-entry))) + (elfeed-show-add-enclosure-to-playlist enclosure-index) + (with-no-warnings + (with-current-emms-playlist + (save-excursion + (emms-playlist-last) + (emms-playlist-mode-play-current-track))))) + +(defun elfeed-show-add-enclosure-to-playlist (enclosure-index) + "Add enclosure number ENCLOSURE-INDEX to current EMMS playlist. +Prompts for ENCLOSURE-INDEX when called interactively." + + (interactive (list (elfeed--enclosure-maybe-prompt-index elfeed-show-entry))) + (require 'emms) ;; optional + (with-no-warnings ;; due to lazy (require ) + (emms-add-url (car (elt (elfeed-entry-enclosures elfeed-show-entry) + (- enclosure-index 1)))))) + +(defun elfeed-show-next-link () + "Skip to the next link, exclusive of the Link header." + (interactive) + (let ((properties (text-properties-at (line-beginning-position)))) + (when (memq 'message-header-name properties) + (forward-paragraph)) + (shr-next-link))) + +(defun elfeed-kill-link-url-at-point () + "Get link URL at point and store in kill-ring." + (interactive) + (let ((url (or (elfeed-get-link-at-point) + (elfeed-get-url-at-point)))) + (if url + (progn (kill-new url) (message url)) + (call-interactively 'shr-copy-url)))) + +;; Bookmarks + +;;;###autoload +(defun elfeed-show-bookmark-handler (record) + "Show the bookmarked entry saved in the `RECORD'." + (let* ((id (bookmark-prop-get record 'id)) + (entry (elfeed-db-get-entry id)) + (position (bookmark-get-position record))) + (elfeed-show-entry entry) + (goto-char position))) + +(defun elfeed-show-bookmark-make-record () + "Save the current position and the entry into a bookmark." + (let ((id (elfeed-entry-id elfeed-show-entry)) + (position (point)) + (title (elfeed-entry-title elfeed-show-entry))) + `(,(format "elfeed entry \"%s\"" title) + (id . ,id) + (location . ,title) + (position . ,position) + (handler . elfeed-show-bookmark-handler)))) + +(provide 'elfeed-show) + +;;; elfeed-show.el ends here blob - /dev/null blob + 317a1c1481d9b2bd812ad67c26dc149738dbad5b (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/elfeed.el @@ -0,0 +1,667 @@ +;;; elfeed.el --- an Emacs Atom/RSS feed reader -*- lexical-binding: t; -*- + +;; This is free and unencumbered software released into the public domain. + +;; Author: Christopher Wellons +;; Package-Version: 3.4.2 +;; Package-Revision: 3.4.2-0-g904b6d4feca7 +;; URL: https://github.com/skeeto/elfeed + +;;; Commentary: + +;; Elfeed is a web feed client for Emacs, inspired by notmuch. See +;; the README for full documentation. + +;;; Code: + +(require 'cl-lib) +(require 'xml) +(require 'xml-query) +(require 'url-parse) +(require 'url-queue) + +(require 'elfeed-db) +(require 'elfeed-lib) +(require 'elfeed-log) +(require 'elfeed-curl) + +;; Interface to elfeed-search (lazy required) +(declare-function elfeed-search-buffer 'elfeed-search ()) +(declare-function elfeed-search-mode 'elfeed-search ()) + +(defgroup elfeed () + "An Emacs web feed reader." + :group 'comm) + +(defconst elfeed-version "3.4.2") + +(defcustom elfeed-feeds () + "List of all feeds that Elfeed should follow. +You must add your feeds to this list. + +In its simplest form this will be a list of strings of feed URLs. +Items in this list can also be list whose car is the feed URL +and cdr is a list of symbols to be applied to all discovered +entries as tags (\"autotags\"). For example, + + (setq elfeed-feeds \\='(\"http://foo/\" + \"http://bar/\" + (\"http://baz/\" comic))) + +All entries from the \"baz\" feed will be tagged as \"comic\" +when they are first discovered." + :group 'elfeed + :type '(repeat (choice string + (cons string (repeat symbol))))) + +(defcustom elfeed-feed-functions + '(elfeed-get-link-at-point + elfeed-get-url-at-point + elfeed-clipboard-get) + "List of functions to use to get possible feeds for `elfeed-add-feed'. +Each function should accept no arguments, and return a string or nil." + :group 'elfeed + :type 'hook + :options '(elfeed-get-link-at-point + elfeed-get-url-at-point + elfeed-clipboard-get)) + +(defcustom elfeed-use-curl + (not (null (executable-find elfeed-curl-program-name))) + "If non-nil, fetch feeds using curl instead of `url-retrieve'." + :group 'elfeed + :type 'boolean) + +(defcustom elfeed-user-agent (format "Emacs Elfeed %s" elfeed-version) + "User agent string to use for Elfeed (requires `elfeed-use-curl')." + :group 'elfeed + :type 'string) + +(defcustom elfeed-initial-tags '(unread) + "Initial tags for new entries." + :group 'elfeed + :type '(repeat symbol)) + +;; Fetching: + +(defvar elfeed-http-error-hooks () + "Hooks to run when an http connection error occurs. +It is called with 2 arguments. The first argument is the url of +the failing feed. The second argument is the http status code.") + +(defvar elfeed-parse-error-hooks () + "Hooks to run when an error occurs during the parsing of a feed. +It is called with 2 arguments. The first argument is the url of +the failing feed. The second argument is the error message .") + +(defvar elfeed-update-hooks () + "Hooks to run any time a feed update has completed a request. +It is called with 1 argument: the URL of the feed that was just +updated. The hook is called even when no new entries were +found.") + +(defvar elfeed-update-init-hooks () + "Hooks called when one or more feed updates have begun. +Receivers may want to, say, update a display to indicate that +updates are pending.") + +(defvar elfeed-tag-hooks () + "Hooks called when one or more entries add tags. +It is called with 2 arguments. The first argument is the entry +list. The second argument is the tag list.") + +(defvar elfeed-untag-hooks () + "Hooks called when one or more entries remove tags. +It is called with 2 arguments. The first argument is the entry +list. The second argument is the tag list.") + +(defvar elfeed--inhibit-update-init-hooks nil + "When non-nil, don't run `elfeed-update-init-hooks'.") + +(defun elfeed-queue-count-active () + "Return the number of items in process." + (if elfeed-use-curl + elfeed-curl-queue-active + (cl-count-if #'url-queue-buffer url-queue))) + +(defun elfeed-queue-count-total () + "Return the number of items in process." + (if elfeed-use-curl + (+ (length elfeed-curl-queue) elfeed-curl-queue-active) + (length url-queue))) + +(defun elfeed-set-max-connections (n) + "Limit the maximum number of concurrent connections to N." + (if elfeed-use-curl + (setf elfeed-curl-max-connections n) + (setf url-queue-parallel-processes n))) + +(defun elfeed-get-max-connections () + "Get the maximum number of concurrent connections." + (if elfeed-use-curl + elfeed-curl-max-connections + url-queue-parallel-processes)) + +(defun elfeed-set-timeout (seconds) + "Limit the time for fetching a feed to SECONDS." + (if elfeed-use-curl + (setf elfeed-curl-timeout seconds) + (setf url-queue-timeout seconds))) + +(defun elfeed-get-timeout () + "Get the time limit for fetching feeds in SECONDS." + (if elfeed-use-curl + elfeed-curl-timeout + url-queue-timeout)) + +(defun elfeed-is-status-error (status use-curl) + "Check if HTTP request returned status means a error." + (or (and use-curl (null status)) ; nil = error + (and (not use-curl) (eq (car status) :error)))) + +(defmacro elfeed-with-fetch (url &rest body) + "Asynchronously run BODY in a buffer with the contents from URL. +This macro is anaphoric, with STATUS referring to the status from +`url-retrieve'/cURL and USE-CURL being the original invoked-value +of `elfeed-use-curl'." + (declare (indent defun)) + `(let* ((use-curl elfeed-use-curl) ; capture current value in closure + (cb (lambda (status) ,@body))) + (if elfeed-use-curl + (let* ((feed (elfeed-db-get-feed url)) + (last-modified (elfeed-meta feed :last-modified)) + (etag (elfeed-meta feed :etag)) + (headers `(("User-Agent" . ,elfeed-user-agent)))) + (when etag + (push `("If-None-Match" . ,etag) headers)) + (when last-modified + (push `("If-Modified-Since" . ,last-modified) headers)) + (elfeed-curl-enqueue ,url cb :headers headers)) + (url-queue-retrieve ,url cb () t t)))) + +(defun elfeed-unjam () + "Manually clear the connection pool when connections fail to timeout. +This is a workaround for issues in `url-queue-retrieve'." + (interactive) + (if elfeed-use-curl + (setf elfeed-curl-queue nil + elfeed-curl-queue-active 0) + (let ((fails (mapcar #'url-queue-url url-queue))) + (when fails + (elfeed-log 'warn "Elfeed aborted feeds: %s" + (mapconcat #'identity fails " "))) + (setf url-queue nil))) + (run-hooks 'elfeed-update-init-hooks)) + +;; Parsing: + +(defun elfeed-feed-type (content) + "Return the feed type (:atom, :rss, :rss1.0) or nil for unknown." + (let ((top (xml-query-strip-ns (caar content)))) + (cadr (assoc top '((feed :atom) + (rss :rss) + (RDF :rss1.0)))))) + +(defun elfeed-generate-id (&optional content) + "Generate an ID based on CONTENT or from the current time." + (concat "urn:sha1:" (sha1 (format "%s" (or content (float-time)))))) + +(defun elfeed--atom-content (entry) + "Get content string from ENTRY." + (let ((content-type (xml-query* (content :type) entry))) + (if (equal content-type "xhtml") + (with-temp-buffer + (let ((xhtml (cddr (xml-query* (content) entry)))) + (dolist (element xhtml) + (if (stringp element) + (insert element) + (elfeed-xml-unparse element)))) + (buffer-string)) + (let ((all-content + (or (xml-query-all* (content *) entry) + (xml-query-all* (summary *) entry)))) + (when all-content + (apply #'concat all-content)))))) + +(defvar elfeed-new-entry-parse-hook '() + "Hook to be called after parsing a new entry. + +Take three arguments: the feed TYPE, the XML structure for the +entry, and the Elfeed ENTRY object. Return value is ignored, and +is called for side-effects on the ENTRY object.") + +(defsubst elfeed--fixup-protocol (protocol url) + "Prepend PROTOCOL to URL if it is protocol-relative. +If PROTOCOL is nil, returns URL." + (if (and protocol url (string-match-p "^//[^/]" url)) + (concat protocol ":" url) + url)) + +(defsubst elfeed--atom-authors-to-plist (authors) + "Parse list of author XML tags into list of plists." + (let ((result ())) + (dolist (author authors) + (let ((plist ()) + (name (xml-query* (name *) author)) + (uri (xml-query* (uri *) author)) + (email (xml-query* (email *) author))) + (when email + (setf plist (list :email (elfeed-cleanup email)))) + (when uri + (setf plist (nconc (list :uri (elfeed-cleanup uri)) plist))) + (when name + (setf plist (nconc (list :name (elfeed-cleanup name)) plist))) + (push plist result))) + (nreverse result))) + +(defsubst elfeed--creators-to-plist (creators) + "Convert Dublin Core list of creators into an authors plist." + (cl-loop for creator in creators + collect (list :name creator))) + +(defun elfeed-entries-from-atom (url xml) + "Turn parsed Atom content into a list of elfeed-entry structs." + (let* ((feed-id url) + (protocol (url-type (url-generic-parse-url url))) + (namespace (elfeed-url-to-namespace url)) + (feed (elfeed-db-get-feed feed-id)) + (title (elfeed-cleanup (xml-query* (feed title *) xml))) + (authors (xml-query-all* (feed author) xml)) + (xml-base (or (xml-query* (feed :base) xml) url)) + (autotags (elfeed-feed-autotags url))) + (setf (elfeed-feed-url feed) url + (elfeed-feed-title feed) title + (elfeed-feed-author feed) (elfeed--atom-authors-to-plist authors)) + (cl-loop for entry in (xml-query-all* (feed entry) xml) collect + (let* ((title (or (xml-query* (title *) entry) "")) + (xml-base (elfeed-update-location + xml-base (xml-query* (:base) (list entry)))) + (anylink (xml-query* (link :href) entry)) + (altlink (xml-query* (link [rel "alternate"] :href) entry)) + (link (elfeed--fixup-protocol + protocol + (elfeed-update-location xml-base + (or altlink anylink)))) + (date (or (xml-query* (published *) entry) + (xml-query* (updated *) entry) + (xml-query* (date *) entry) + (xml-query* (modified *) entry) ; Atom 0.3 + (xml-query* (issued *) entry))) ; Atom 0.3 + (authors (nconc (elfeed--atom-authors-to-plist + (xml-query-all* (author) entry)) + ;; Dublin Core + (elfeed--creators-to-plist + (xml-query-all* (creator *) entry)))) + (categories (xml-query-all* (category :term) entry)) + (content (elfeed--atom-content entry)) + (id (or (xml-query* (id *) entry) link + (elfeed-generate-id content))) + (type (or (xml-query* (content :type) entry) + (xml-query* (summary :type) entry) + "")) + (tags (elfeed-normalize-tags autotags elfeed-initial-tags)) + (content-type (if (string-match-p "html" type) 'html nil)) + (etags (xml-query-all* (link [rel "enclosure"]) entry)) + (enclosures + (cl-loop for enclosure in etags + for wrap = (list enclosure) + for href = (xml-query* (:href) wrap) + for type = (xml-query* (:type) wrap) + for length = (xml-query* (:length) wrap) + collect (list href type length))) + (db-entry (elfeed-entry--create + :title (elfeed-cleanup title) + :feed-id feed-id + :id (cons namespace (elfeed-cleanup id)) + :link (elfeed-cleanup link) + :tags tags + :date (or (elfeed-float-time date) (float-time)) + :content content + :enclosures enclosures + :content-type content-type + :meta `(,@(when authors + (list :authors authors)) + ,@(when categories + (list :categories categories)))))) + (dolist (hook elfeed-new-entry-parse-hook) + (funcall hook :atom entry db-entry)) + db-entry)))) + +(defsubst elfeed--rss-author-to-plist (author) + "Parse an RSS author element into an authors plist." + (when author + (let ((clean (elfeed-cleanup author))) + (if (string-match "^\\(.*\\) (\\([^)]+\\))$" clean) + (list (list :name (match-string 2 clean) + :email (match-string 1 clean))) + (list (list :email clean)))))) + +(defun elfeed-entries-from-rss (url xml) + "Turn parsed RSS content into a list of elfeed-entry structs." + (let* ((feed-id url) + (protocol (url-type (url-generic-parse-url url))) + (namespace (elfeed-url-to-namespace url)) + (feed (elfeed-db-get-feed feed-id)) + (title (elfeed-cleanup (xml-query* (rss channel title *) xml))) + (autotags (elfeed-feed-autotags url))) + (setf (elfeed-feed-url feed) url + (elfeed-feed-title feed) title) + (cl-loop for item in (xml-query-all* (rss channel item) xml) collect + (let* ((title (or (xml-query* (title *) item) "")) + (guid (xml-query* (guid *) item)) + (link (elfeed--fixup-protocol + protocol + (or (xml-query* (link *) item) guid))) + (date (or (xml-query* (pubDate *) item) + (xml-query* (date *) item))) + (authors (nconc (elfeed--rss-author-to-plist + (xml-query* (author *) item)) + ;; Dublin Core + (elfeed--creators-to-plist + (xml-query-all* (creator *) item)))) + (categories (xml-query-all* (category *) item)) + (content (or (xml-query-all* (encoded *) item) + (xml-query-all* (description *) item))) + (description (apply #'concat content)) + (id (or guid link (elfeed-generate-id description))) + (full-id (cons namespace (elfeed-cleanup id))) + (original (elfeed-db-get-entry full-id)) + (original-date (and original (elfeed-entry-date original))) + (tags (elfeed-normalize-tags autotags elfeed-initial-tags)) + (etags (xml-query-all* (enclosure) item)) + (enclosures + (cl-loop for enclosure in etags + for wrap = (list enclosure) + for url = (xml-query* (:url) wrap) + for type = (xml-query* (:type) wrap) + for length = (xml-query* (:length) wrap) + collect (list url type length))) + (db-entry (elfeed-entry--create + :title (elfeed-cleanup title) + :id full-id + :feed-id feed-id + :link (elfeed-cleanup link) + :tags tags + :date (elfeed-new-date-for-entry + original-date date) + :enclosures enclosures + :content description + :content-type 'html + :meta `(,@(when authors + (list :authors authors)) + ,@(when categories + (list :categories categories)))))) + (dolist (hook elfeed-new-entry-parse-hook) + (funcall hook :rss item db-entry)) + db-entry)))) + +(defun elfeed-entries-from-rss1.0 (url xml) + "Turn parsed RSS 1.0 content into a list of elfeed-entry structs." + (let* ((feed-id url) + (namespace (elfeed-url-to-namespace url)) + (feed (elfeed-db-get-feed feed-id)) + (title (elfeed-cleanup (xml-query* (RDF channel title *) xml))) + (autotags (elfeed-feed-autotags url))) + (setf (elfeed-feed-url feed) url + (elfeed-feed-title feed) title) + (cl-loop for item in (xml-query-all* (RDF item) xml) collect + (let* ((title (or (xml-query* (title *) item) "")) + (link (xml-query* (link *) item)) + (date (or (xml-query* (pubDate *) item) + (xml-query* (date *) item))) + (description + (apply #'concat (xml-query-all* (description *) item))) + (id (or link (elfeed-generate-id description))) + (full-id (cons namespace (elfeed-cleanup id))) + (original (elfeed-db-get-entry full-id)) + (original-date (and original (elfeed-entry-date original))) + (tags (elfeed-normalize-tags autotags elfeed-initial-tags)) + (db-entry (elfeed-entry--create + :title (elfeed-cleanup title) + :id full-id + :feed-id feed-id + :link (elfeed-cleanup link) + :tags tags + :date (elfeed-new-date-for-entry + original-date date) + :content description + :content-type 'html))) + (dolist (hook elfeed-new-entry-parse-hook) + (funcall hook :rss1.0 item db-entry)) + db-entry)))) + +(defun elfeed-feed-list () + "Return a flat list version of `elfeed-feeds'. +Only a list of strings will be returned." + ;; Validate elfeed-feeds and fail early rather than asynchronously later. + (dolist (feed elfeed-feeds) + (unless (cl-typecase feed + (list (and (stringp (car feed)) + (cl-every #'symbolp (cdr feed)))) + (string t)) + (error "elfeed-feeds malformed, bad entry: %S" feed))) + (cl-loop for feed in elfeed-feeds + when (listp feed) collect (car feed) + else collect feed)) + +(defun elfeed-feed-autotags (url-or-feed) + "Return tags to automatically apply to all entries from URL-OR-FEED." + (let ((url (if (elfeed-feed-p url-or-feed) + (or (elfeed-feed-url url-or-feed) + (elfeed-feed-id url-or-feed)) + url-or-feed))) + (mapcar #'elfeed-keyword->symbol (cdr (assoc url elfeed-feeds))))) + +(defun elfeed-apply-autotags-now () + "Apply autotags to existing entries according to `elfeed-feeds'." + (interactive) + (with-elfeed-db-visit (entry feed) + (apply #'elfeed-tag entry (elfeed-feed-autotags feed)))) + +(defun elfeed-handle-http-error (url status) + "Handle an http error during retrieval of URL with STATUS code." + (cl-incf (elfeed-meta (elfeed-db-get-feed url) :failures 0)) + (run-hook-with-args 'elfeed-http-error-hooks url status) + (elfeed-log 'error "%s: %S" url status)) + +(defun elfeed-handle-parse-error (url error) + "Handle parse error during parsing of URL with ERROR message." + (cl-incf (elfeed-meta (elfeed-db-get-feed url) :failures 0)) + (run-hook-with-args 'elfeed-parse-error-hooks url error) + (elfeed-log 'error "%s: %s" url error)) + +(defun elfeed-update-feed (url) + "Update a specific feed." + (interactive (list (completing-read "Feed: " (elfeed-feed-list)))) + (unless elfeed--inhibit-update-init-hooks + (run-hooks 'elfeed-update-init-hooks)) + (elfeed-with-fetch url + (if (elfeed-is-status-error status use-curl) + (let ((print-escape-newlines t)) + (elfeed-handle-http-error + url (if use-curl elfeed-curl-error-message status))) + (condition-case error + (let ((feed (elfeed-db-get-feed url))) + (unless use-curl + (elfeed-move-to-first-empty-line) + (set-buffer-multibyte t)) + (unless (eql elfeed-curl-status-code 304) + ;; Update Last-Modified and Etag + (setf (elfeed-meta feed :last-modified) + (cdr (assoc "last-modified" elfeed-curl-headers)) + (elfeed-meta feed :etag) + (cdr (assoc "etag" elfeed-curl-headers))) + (if (equal url elfeed-curl-location) + (setf (elfeed-meta feed :canonical-url) nil) + (setf (elfeed-meta feed :canonical-url) elfeed-curl-location)) + (let* ((xml (elfeed-xml-parse-region (point) (point-max))) + (entries (cl-case (elfeed-feed-type xml) + (:atom (elfeed-entries-from-atom url xml)) + (:rss (elfeed-entries-from-rss url xml)) + (:rss1.0 (elfeed-entries-from-rss1.0 url xml)) + (otherwise + (error (elfeed-handle-parse-error + url "Unknown feed type.")))))) + (elfeed-db-add entries)))) + (error (elfeed-handle-parse-error url error)))) + (unless use-curl + (kill-buffer)) + (run-hook-with-args 'elfeed-update-hooks url))) + +(defun elfeed-candidate-feeds () + "Return a list of possible feeds from `elfeed-feed-functions'." + (let (res) + (run-hook-wrapped + 'elfeed-feed-functions + (lambda (fun) + (let* ((val (elfeed-cleanup (funcall fun)))) + (when (and (not (zerop (length val))) + (elfeed-looks-like-url-p val)) + (cl-pushnew val res :test #'equal))) + nil)) + (nreverse res))) + +(cl-defun elfeed-add-feed (url &key save) + "Manually add a feed to the database. +If SAVE is non-nil the new value of ‘elfeed-feeds’ is saved. When +called interactively, SAVE is set to t." + (interactive + (list + (let* ((feeds (elfeed-candidate-feeds)) + (prompt (if feeds (concat "URL (default " (car feeds) "): ") + "URL: ")) + (input (read-from-minibuffer prompt nil nil nil nil feeds)) + (result (elfeed-cleanup input))) + (cond ((not (zerop (length result))) result) + (feeds (car feeds)) + ((user-error "No feed to add")))) + :save t)) + (cl-pushnew url elfeed-feeds :test #'equal) + (when save + (customize-save-variable 'elfeed-feeds elfeed-feeds)) + (elfeed-update-feed url)) + +;;;###autoload +(defun elfeed-update () + "Update all the feeds in `elfeed-feeds'." + (interactive) + (elfeed-log 'info "Elfeed update: %s" + (format-time-string "%B %e %Y %H:%M:%S %Z")) + (let ((elfeed--inhibit-update-init-hooks t)) + (mapc #'elfeed-update-feed (elfeed--shuffle (elfeed-feed-list)))) + (run-hooks 'elfeed-update-init-hooks) + (elfeed-db-save)) + +;;;###autoload +(defun elfeed () + "Enter elfeed." + (interactive) + (switch-to-buffer (elfeed-search-buffer)) + (unless (eq major-mode 'elfeed-search-mode) + (elfeed-search-mode))) + +;; New entry filtering + +(cl-defun elfeed-make-tagger + (&key feed-title feed-url entry-title entry-link after before + add remove callback) + "Create a function that adds or removes tags on matching entries. + +FEED-TITLE, FEED-URL, ENTRY-TITLE, and ENTRY-LINK are regular +expressions or a list (not ), which indicates a negative +match. AFTER and BEFORE are relative times (see +`elfeed-time-duration'). Entries must match all provided +expressions. If an entry matches, add tags ADD and remove tags +REMOVE. + +Examples, + + (elfeed-make-tagger :feed-url \"youtube\\\\.com\" + :add \\='(video youtube)) + + (elfeed-make-tagger :before \"1 week ago\" + :remove \\='unread) + + (elfeed-make-tagger :feed-url \"example\\\\.com\" + :entry-title \\='(not \"something interesting\") + :add \\='junk) + +The returned function should be added to `elfeed-new-entry-hook'." + (let ((after-time (and after (elfeed-time-duration after))) + (before-time (and before (elfeed-time-duration before)))) + (when (and add (symbolp add)) (setf add (list add))) + (when (and remove (symbolp remove)) (setf remove (list remove))) + (lambda (entry) + (let ((feed (elfeed-entry-feed entry)) + (date (elfeed-entry-date entry)) + (case-fold-search t)) + (cl-flet ((match (r s) + (or (null r) + (if (listp r) + (not (string-match-p (cl-second r) s)) + (string-match-p r s))))) + (when (and + (match feed-title (elfeed-feed-title feed)) + (match feed-url (elfeed-feed-url feed)) + (match entry-title (elfeed-entry-title entry)) + (match entry-link (elfeed-entry-link entry)) + (or (not after-time) (> date (- (float-time) after-time))) + (or (not before-time) (< date (- (float-time) before-time)))) + (when add + (apply #'elfeed-tag entry add)) + (when remove + (apply #'elfeed-untag entry remove)) + (when callback + (funcall callback entry)) + entry)))))) + +;; OPML + +(defun elfeed--parse-opml (xml) + "Parse XML (from `xml-parse-region') into `elfeed-feeds' list." + (cl-loop for (tag attr . content) in (cl-remove-if-not #'listp xml) + count tag into work-around-bug ; bug#15326 + when (assoc 'xmlUrl attr) collect (cdr it) + else append (elfeed--parse-opml content))) + +;;;###autoload +(defun elfeed-load-opml (file) + "Load feeds from an OPML file into `elfeed-feeds'. +When called interactively, the changes to `elfeed-feeds' are +saved to your customization file." + (interactive "fOPML file: ") + (let* ((xml (xml-parse-file file)) + (feeds (elfeed--parse-opml xml)) + (full (append feeds elfeed-feeds))) + (prog1 (setf elfeed-feeds (cl-delete-duplicates full :test #'string=)) + (when (called-interactively-p 'any) + (customize-save-variable 'elfeed-feeds elfeed-feeds) + (elfeed-log 'notice "%d feeds loaded from %s" (length feeds) file))))) + +;;;###autoload +(defun elfeed-export-opml (file) + "Export the current feed listing to OPML-formatted FILE." + (interactive "FOutput OPML file: ") + (with-temp-file file + (let ((standard-output (current-buffer))) + (princ "\n") + (xml-print + `((opml ((version . "1.0")) + (head () (title () "Elfeed Export")) + (body () + ,@(cl-loop for url in (elfeed-feed-list) + for feed = (elfeed-db-get-feed url) + for title = (or (elfeed-feed-title feed) "") + collect `(outline ((xmlUrl . ,url) + (title . ,title))))))))))) + +(provide 'elfeed) + +(cl-eval-when (load eval) + ;; run-time only, so don't load when compiling other files + (unless byte-compile-root-dir + (require 'elfeed-csv) + (require 'elfeed-show) + (require 'elfeed-search))) + +;;; elfeed.el ends here blob - /dev/null blob + a007a7f88d3296b94f0a269ea45d413dcade777a (mode 644) --- /dev/null +++ elpa/elfeed-3.4.2/xml-query.el @@ -0,0 +1,231 @@ +;;; xml-query.el --- query engine complimenting the xml package + +;; This is free and unencumbered software released into the public domain. + +;;; Commentary: + +;; This provides a very rudimentary, jQuery-like, XML selector +;; s-expression language. It operates on the output of the xml +;; package, such as `xml-parse-region' and `xml-parse-file'. It was +;; written to support Elfeed. + +;; See the docstring for `xml-query-all'. + +;; The macro forms, `xml-query*' and `xml-query-all*', are an order of +;; magnitude faster, but only work on static selectors and need the +;; namespaces to be pre-stripped. + +;; Examples: + +;; This query grabs the top-level paragraph content from XHTML. + +;; (xml-query-all '(html body p *) xhtml) + +;; This query extracts all the links from an Atom feed. + +;; (xml-query-all '(feed entry link [rel "alternate"] :href) xml) + +;;; Code: + +(require 'cl-lib) + +(defun xml-query-strip-ns (tag) + "Remove the namespace, if any, from TAG." + (when (symbolp tag) + (let ((name (symbol-name tag))) + (if (cl-find ?\: name) + (intern (replace-regexp-in-string "^.+:" "" name)) + tag)))) + +(defun xml-query--tag-all (match xml) + (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml) + when (or (eq tag match) (eq (xml-query-strip-ns tag) match)) + collect (cons tag (cons attribs content)))) + +(defun xml-query--attrib-all (attrib value xml) + (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml) + when (equal (cdr (assoc attrib attribs)) value) + collect (cons tag (cons attribs content)))) + +(defun xml-query--keyword (matcher xml) + (cl-loop with match = (intern (substring (symbol-name matcher) 1)) + for (tag attribs . content) in (cl-remove-if-not #'listp xml) + when (cdr (assoc match attribs)) + collect it)) + +(defun xml-query--symbol (matcher xml) + (xml-query--tag-all matcher xml)) + +(defun xml-query--vector (matcher xml) + (let ((attrib (aref matcher 0)) + (value (aref matcher 1))) + (xml-query--attrib-all attrib value xml))) + +(defun xml-query--list (matchers xml) + (cl-loop for matcher in matchers + append (xml-query-all (if (listp matcher) + matcher + (list matcher)) xml))) + +(defun xml-query--append (xml) + (cl-loop for (tag attribs . content) in (cl-remove-if-not #'listp xml) + append content)) + +(defun xml-query--stringp (thing) + "Return non-nil of THING is a non-blank string." + (and (stringp thing) (string-match "[^ \t\r\n]" thing))) + +(defun xml-query-all (query xml) + "Given a list of tags, XML, apply QUERY and return a list of +matching tags. + +A query is a list of matchers. + - SYMBOL: filters to matching tags + - LIST: each element is a full sub-query, whose results are concatenated + - VECTOR: filters to tags with matching attribute, [tag attrib value] + - KEYWORD: filters to an attribute value (must be last) + - * (an asterisk symbol): filters to content strings (must be last) + +For example, to find all the \"alternate\" link URL in a typical +Atom feed: + + (xml-query-all \\='(feed entry link [rel \"alternate\"] :href) xml)" + (if (null query) + xml + (cl-destructuring-bind (matcher . rest) query + (cond + ((keywordp matcher) (xml-query--keyword matcher xml)) + ((eq matcher '*) + (cl-remove-if-not #'xml-query--stringp (xml-query--append xml))) + (:else + (let ((matches + (cl-etypecase matcher + (symbol (xml-query--symbol matcher xml)) + (vector (xml-query--vector matcher xml)) + (list (xml-query--list matcher xml))))) + (cond + ((null rest) matches) + ((and (or (symbolp (car rest)) + (listp (car rest))) + (not (keywordp (car rest))) + (not (eq '* (car rest)))) + (xml-query-all (cdr query) (xml-query--append matches))) + (:else (xml-query-all rest matches))))))))) + +(defun xml-query (query xml) + "Like `xml-query-all' but only return the first result." + (let ((result (xml-query-all query xml))) + (if (xml-query--stringp result) + result + (car (xml-query-all query xml))))) + +;; Macro alternatives: + +;; This is a slightly less capable alternative with significantly +;; better performance (x10 speedup) that requires a static selector. +;; The selector is compiled into Lisp code via macro at compile-time, +;; which is then carried through to byte-code by the compiler. In +;; byte-code form, the macro performs no function calls other than +;; `throw' in the case of `xml-query*', where it's invoked less than +;; once per evaluation (only on success). + +;; Queries are compiled tail-to-head with a result handler at the +;; deepest level. The generated code makes multiple bindings of the +;; variable "v" as it dives deeper into the query, using the layers of +;; bindings as a breadcrumb stack. + +;; For `xml-query*', which has a single result, the whole expression +;; is wrapped in a catch, and the first successful match is thrown to +;; it from the result handler. + +;; For `xml-query-all*', the result is pushed into an output list. + +(defun xml-query--compile-tag (tag subexp subloop-p) + `(when (and (consp v) (eq (car v) ',tag)) + ,(if subloop-p + `(dolist (v (cddr v)) + ,subexp) + subexp))) + +(defun xml-query--compile-attrib (pair subexp subloop-p) + `(let ((value (cdr (assq ',(aref pair 0) (cadr v))))) + (when (equal value ,(aref pair 1)) + ,(if subloop-p + `(dolist (v (cddr v)) + ,subexp) + subexp)))) + +(defun xml-query--compile-keyword (keyword subexp) + (let ((attrib (intern (substring (symbol-name keyword) 1)))) + `(let ((v (cdr (assq ',attrib (cadr v))))) + (when v + ,subexp)))) + +(defun xml-query--compile-star (subexp) + `(when (and (stringp v) (string-match "[^ \t\r\n]" v)) + ,subexp)) + +(defun xml-query--compile-top (query input subexp) + (let* ((rquery (reverse query)) + (prev nil)) + (while rquery + (let ((matcher (pop rquery)) + ;; Should the next item loop over its children? + (subloop-p (and (not (null prev)) + (not (keywordp prev)) + (symbolp prev)))) + (cond + ((eq '* matcher) + (setf subexp (xml-query--compile-star subexp))) + ((keywordp matcher) + (setf subexp (xml-query--compile-keyword matcher subexp))) + ((symbolp matcher) + (setf subexp (xml-query--compile-tag matcher subexp subloop-p))) + ((vectorp matcher) + (setf subexp (xml-query--compile-attrib matcher subexp subloop-p))) + ((error "Bad query: %S" query))) + (setf prev matcher))) + `(dolist (v ,input) + ,subexp))) + +(defun xml-query--compile (query input) + (let ((tag (make-symbol "done"))) + `(catch ',tag + ,(xml-query--compile-top query input `(throw ',tag v))))) + +(defmacro xml-query* (query sexp) + "Like `xml-query' but generate code to execute QUERY on SEXP. + +Unlike `xml-query', QUERY must be a static, compile-time +s-expression. See `xml-query-all*' for more information. + +QUERY is *not* evaluated, so it should not be quoted." + (xml-query--compile query sexp)) + +(defun xml-query-all--compile (query input) + (let ((output (make-symbol "output"))) + `(let ((,output ())) + ,(xml-query--compile-top query input `(push v ,output)) + (nreverse ,output)))) + +(defmacro xml-query-all* (query sexp) + "Like `xml-query-all' but generate code to execute QUERY on SEXP. + +Unlike `xml-query-all', QUERY must be a static, compile-time +s-expression. This macro compiles the query into actual code. The +result is faster since the query will be compiled into byte-code +rather than \"interpreted\" at run time. + +Also unlike `xml-query-all', the parsed XML s-expression must +also have its namespace pre-stripped. This is accomplished by +setting the optional PARSE-NS argument of `xml-parse-region' to +symbol-qnames. + +Sub-expression lists are not supported by this macro. + +QUERY is *not* evaluated, so it should not be quoted." + (xml-query-all--compile query sexp)) + +(provide 'xml-query) + +;;; xml-query.el ends here blob - /dev/null blob + 7c6424f06575b45d68236d57f8c2a582c0d07299 (mode 644) --- /dev/null +++ elpa/llama-1.0.0/.dir-locals.el @@ -0,0 +1,6 @@ +((nil + (indent-tabs-mode . nil)) + (makefile-mode + (indent-tabs-mode . t)) + (git-commit-mode + (git-commit-major-mode . git-commit-elisp-text-mode))) blob - /dev/null blob + aab6b57df675a46c9544ef49fbd276ffcfb235bb (mode 644) --- /dev/null +++ elpa/llama-1.0.0/Makefile @@ -0,0 +1,70 @@ +-include .config.mk + +PKG = llama + +ELS = $(PKG).el +ELS += $(PKG)-test.el +ELCS = $(ELS:.el=.elc) + +$(PKG).elc: +$(PKG)-test.elc: $(PKG).elc + +DEPS = compat + +EMACS ?= emacs +EMACS_ARGS ?= --eval "(progn \ + (put 'if-let 'byte-obsolete-info nil) \ + (put 'when-let 'byte-obsolete-info nil))" + +LOAD_PATH ?= $(addprefix -L ../,$(DEPS)) +LOAD_PATH += -L . + +all: lisp + +help: + $(info make all - generate byte-code and autoloads) + $(info make lisp - generate byte-code and autoloads) + $(info make redo - re-generate byte-code and autoloads) + $(info make test - run tests) + $(info make clean - remove generated files) + @printf "\n" + +redo: clean lisp + +lisp: $(ELCS) loaddefs check-declare + +loaddefs: $(PKG)-autoloads.el + +%.elc: %.el + @printf "Compiling $<\n" + @$(EMACS) -Q --batch $(EMACS_ARGS) $(LOAD_PATH) -f batch-byte-compile $< + +check-declare: + @printf " Checking function declarations\n" + @$(EMACS) -Q --batch $(EMACS_ARGS) $(LOAD_PATH) \ + --eval "(check-declare-directory default-directory)" + +test: lisp + @$(EMACS) -Q --batch $(EMACS_ARGS) $(LOAD_PATH) \ + -l ert -l $(PKG)-test.el -f ert-run-tests-batch-and-exit + +CLEAN = $(ELCS) $(PKG)-autoloads.el + +clean: + @printf " Cleaning...\n" + @rm -rf $(CLEAN) + +$(PKG)-autoloads.el: $(ELS) + @printf " Creating $@\n" + @$(EMACS) -Q --batch -l autoload -l cl-lib --eval "\ +(let ((file (expand-file-name \"$@\"))\ + (autoload-timestamps nil) \ + (backup-inhibited t)\ + (version-control 'never)\ + (coding-system-for-write 'utf-8-emacs-unix))\ + (write-region (autoload-rubric file \"package\" nil) nil file nil 'silent)\ + (cl-letf (((symbol-function 'progress-reporter-do-update) (lambda (&rest _)))\ + ((symbol-function 'progress-reporter-done) (lambda (_))))\ + (let ((generated-autoload-file file))\ + (update-directory-autoloads default-directory))))" \ + 2>&1 | sed "/^Package autoload is deprecated$$/d" blob - /dev/null blob + 809f657c9b2ca38976dc48506214314908a8dda2 (mode 644) --- /dev/null +++ elpa/llama-1.0.0/README-elpa @@ -0,0 +1,71 @@ +1 Llama — Compact syntax for short lambda +═════════════════════════════════════════ + + This package implements a macro named `##', which provides a compact + way to write short `lambda' expressions. + + The signature of the macro is `(## FN &rest BODY)' and it expands to a + `lambda' expression, which calls the function `FN' with the arguments + `BODY' and returns the value of that. The arguments of the `lambda' + expression are derived from symbols found in `BODY'. + + Each symbol from `%1' through `%9', which appears in an unquoted part + of `BODY', specifies a mandatory argument. Each symbol from `&1' + through `&9', which appears in an unquoted part of `BODY', specifies + an optional argument. The symbol `&*' specifies extra (`&rest') + arguments. + + The shorter symbol `%' can be used instead of `%1', but using both in + the same expression is not allowed. Likewise `&' can be used instead + of `&1'. These shorthands are not recognized in function position. + + To support binding forms that use a vector as `VARLIST' (such as + `-let' from the `dash' package), argument symbols are also detected + inside of vectors. + + The space between `##' and `FN' can be omitted because `##' is + read-syntax for the symbol whose name is the empty string. If you + prefer you can place a space there anyway, and if you prefer to not + use this somewhat magical symbol at all, you can instead use the + alternative name `llama'. + + Instead of: + + ┌──── + │ (lambda (a &optional _ c &rest d) + │ (foo a (bar c) d)) + └──── + + you can use this macro and write: + + ┌──── + │ (##foo %1 (bar &3) &*) + └──── + + which expands to: + + ┌──── + │ (lambda (%1 &optional _&2 &3 &rest &*) + │ (foo %1 (bar &3) &*)) + └──── + + Unused trailing arguments and mandatory unused arguments at the border + between mandatory and optional arguments are also supported: + + ┌──── + │ (##list %1 _%3 &5 _&6) + └──── + + becomes: + + ┌──── + │ (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) + │ (list %1 &5)) + └──── + + Note how `_%3' and `_&6' are removed from the body, because their + names begin with an underscore. Also note that `_&4' is optional, + unlike the explicitly specified `_%3'. + + Consider enabling `llama-fontify-mode' to highlight `##' and its + special arguments. blob - /dev/null blob + 42134f29f5c5a8c27f564138dd4d8ec8ad9af117 (mode 644) --- /dev/null +++ elpa/llama-1.0.0/README.org @@ -0,0 +1,68 @@ +* Llama — Compact syntax for short lambda + +This package implements a macro named ~##~, which provides a compact way +to write short ~lambda~ expressions. + +The signature of the macro is ~(## FN &rest BODY)~ and it expands to a +~lambda~ expression, which calls the function ~FN~ with the arguments ~BODY~ +and returns the value of that. The arguments of the ~lambda~ expression +are derived from symbols found in ~BODY~. + +Each symbol from ~%1~ through ~%9~, which appears in an unquoted part +of ~BODY~, specifies a mandatory argument. Each symbol from ~&1~ through +~&9~, which appears in an unquoted part of ~BODY~, specifies an optional +argument. The symbol ~&*~ specifies extra (~&rest~) arguments. + +The shorter symbol ~%~ can be used instead of ~%1~, but using both in +the same expression is not allowed. Likewise ~&~ can be used instead +of ~&1~. These shorthands are not recognized in function position. + +To support binding forms that use a vector as ~VARLIST~ (such as ~-let~ +from the ~dash~ package), argument symbols are also detected inside of +vectors. + +The space between ~##~ and ~FN~ can be omitted because ~##~ is read-syntax +for the symbol whose name is the empty string. If you prefer you can +place a space there anyway, and if you prefer to not use this somewhat +magical symbol at all, you can instead use the alternative name ~llama~. + +Instead of: + +#+begin_src emacs-lisp + (lambda (a &optional _ c &rest d) + (foo a (bar c) d)) +#+end_src + +you can use this macro and write: + +#+begin_src emacs-lisp + (##foo %1 (bar &3) &*) +#+end_src + +which expands to: + +#+begin_src emacs-lisp + (lambda (%1 &optional _&2 &3 &rest &*) + (foo %1 (bar &3) &*)) +#+end_src + +Unused trailing arguments and mandatory unused arguments at the border +between mandatory and optional arguments are also supported: + +#+begin_src emacs-lisp + (##list %1 _%3 &5 _&6) +#+end_src + +becomes: + +#+begin_src emacs-lisp + (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) + (list %1 &5)) +#+end_src + +Note how ~_%3~ and ~_&6~ are removed from the body, because their names +begin with an underscore. Also note that ~_&4~ is optional, unlike the +explicitly specified ~_%3~. + +Consider enabling ~llama-fontify-mode~ to highlight ~##~ and its special +arguments. blob - /dev/null blob + 155fd935e3980c88999e6fd81575b6fc6ddda59c (mode 644) --- /dev/null +++ elpa/llama-1.0.0/llama-autoloads.el @@ -0,0 +1,117 @@ +;;; llama-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from llama.el + +(autoload 'llama "llama" "\ +Expand to a `lambda' expression that wraps around FN and BODY. + +This macro provides a compact way to write short `lambda' expressions. +It expands to a `lambda' expression, which calls the function FN with +arguments BODY and returns its value. The arguments of the `lambda' +expression are derived from symbols found in BODY. + +Each symbol from `%1' through `%9', which appears in an unquoted part +of BODY, specifies a mandatory argument. Each symbol from `&1' through +`&9', which appears in an unquoted part of BODY, specifies an optional +argument. The symbol `&*' specifies extra (`&rest') arguments. + +The shorter symbol `%' can be used instead of `%1', but using both in +the same expression is not allowed. Likewise `&' can be used instead +of `&1'. These shorthands are not recognized in function position. + +To support binding forms that use a vector as VARLIST (such as `-let' +from the `dash' package), argument symbols are also detected inside of +vectors. + +The space between `##' and FN can be omitted because `##' is read-syntax +for the symbol whose name is the empty string. If you prefer you can +place a space there anyway, and if you prefer to not use this somewhat +magical symbol at all, you can instead use the alternative name `llama'. + +Instead of: + + (lambda (a &optional _ c &rest d) + (foo a (bar c) d)) + +you can use this macro and write: + + (##foo %1 (bar &3) &*) + +which expands to: + + (lambda (%1 &optional _&2 &3 &rest &*) + (foo %1 (bar &3) &*)) + +Unused trailing arguments and mandatory unused arguments at the border +between mandatory and optional arguments are also supported: + + (##list %1 _%3 &5 _&6) + +becomes: + + (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) + (list %1 &5)) + +Note how `_%3' and `_&6' are removed from the body, because their names +begin with an underscore. Also note that `_&4' is optional, unlike the +explicitly specified `_%3'. + +Consider enabling `llama-fontify-mode' to highlight `##' and its +special arguments. + +(fn FN &rest BODY)" nil t) +(defvar llama-fontify-mode nil "\ +Non-nil if Llama-Fontify mode is enabled. +See the `llama-fontify-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `llama-fontify-mode'.") +(custom-autoload 'llama-fontify-mode "llama" nil) +(autoload 'llama-fontify-mode "llama" "\ +In Emacs Lisp mode, highlight the `##' macro and its special arguments. + +This is a global minor mode. If called interactively, toggle the +`Llama-Fontify mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='llama-fontify-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "llama" '("##" "all-completions" "elisp-" "intern" "lisp--el-match-keyword@llama" "llama-")) + + +;;; Generated autoloads from llama-test.el + +(register-definition-prefixes "llama-test" '("llama-test--flatten")) + +;;; End of scraped data + +(provide 'llama-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; llama-autoloads.el ends here blob - /dev/null blob + 604d427290ed17ec030d91cb8ceb61021bc43c4e (mode 644) --- /dev/null +++ elpa/llama-1.0.0/llama-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from llama.el -*- no-byte-compile: t -*- +(define-package "llama" "1.0.0" "Compact syntax for short lambda" '((emacs "26.1") (compat "30.1")) :commit "0cc2daffded18eea7f00a318cfa3e216977ffe50" :keywords '("extensions") :url "https://github.com/tarsius/llama") blob - /dev/null blob + 1d2f46fc9cc41b1f20e4e4e650d49b1fce288d61 (mode 644) --- /dev/null +++ elpa/llama-1.0.0/llama-test.el @@ -0,0 +1,525 @@ +;;; llama-tests.el --- Tests for Llama -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2025 Jonas Bernoulli + +;; Authors: Jonas Bernoulli +;; Homepage: https://github.com/tarsius/llama +;; Keywords: extensions + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; 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 3 of the License, +;; 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 this file. If not, see . + +;;; Code: + +(require 'llama) + +(ert-deftest llama-test-101-basic nil + + (should (equal (##list %1) + (lambda (%1) + (list %1)))) + + (should (equal (##list %1 %1) + (lambda (%1) + (list %1 %1)))) + + (should (equal (##list %1 %2) + (lambda (%1 %2) + (list %1 %2)))) + + (should (equal (##list %2 %1) + (lambda (%1 %2) + (list %2 %1)))) + + (should (equal (##list 'const %1) + (lambda ( %1) + (list 'const %1)))) + + (should (equal (##list %1 'const) + (lambda (%1) + (list %1 'const)))) + + (should (equal (##list %1 'const %2) + (lambda (%1 %2) + (list %1 'const %2)))) + + (should (equal (##list %2 'const %1) + (lambda (%1 %2) + (list %2 'const %1)))) + + (should (equal (##list %1 %2 %3 %4 %5 %6 %7 %8 %9) + (lambda (%1 %2 %3 %4 %5 %6 %7 %8 %9) + (list %1 %2 %3 %4 %5 %6 %7 %8 %9)))) + + (should (equal (##list %1 %2 %1 %3 %5 %4 %6 %7 %9 %8) + (lambda (%1 %2 %3 %4 %5 %6 %7 %8 %9) + (list %1 %2 %1 %3 %5 %4 %6 %7 %9 %8)))) + ) + +(ert-deftest llama-test-102-basic-optional nil + + (should (equal (##list &1) + (lambda (&optional &1) + (list &1)))) + + (should (equal (##list %1 &2) + (lambda (%1 &optional &2) + (list %1 &2)))) + + (should (equal (##list %2 %1 &4 &3) + (lambda ( %1 %2 &optional &3 &4) + (list %2 %1 &4 &3)))) + ) + +(ert-deftest llama-test-103-basic-rest nil + + (should (equal (##list &*) + (lambda (&rest &*) + (list &*)))) + + (should (equal (##list %1 &*) + (lambda (%1 &rest &*) + (list %1 &*)))) + + (should (equal (##list %1 &2 &*) + (lambda (%1 &optional &2 &rest &*) + (list %1 &2 &*)))) + ) + +(ert-deftest llama-test-104-basic-nested nil + + (should (equal (##list (##list %) %1) + (lambda (%1) + (list (lambda (%) (list %)) + %1)))) + ) + +(ert-deftest llama-test-105-basic-nil nil + + (should (equal (##list (##list %) %1) + (lambda (%1) + (list (lambda (%) (list %)) + %1)))) + ) + +(ert-deftest llama-test-201-unused-implicit-mandatory nil + + (should (equal (##list %2) + (lambda (_%1 %2) + (list %2)))) + + (should (equal (##list %2 %3) + (lambda (_%1 %2 %3) + (list %2 %3)))) + + (should (equal (##list %3) + (lambda (_%1 _%2 %3) + (list %3)))) + + (should (equal (##list %1 %3) + (lambda (%1 _%2 %3) + (list %1 %3)))) + + (should (equal (##list %3 %6) + (lambda (_%1 _%2 %3 _%4 _%5 %6) + (list %3 %6)))) + ) + +(ert-deftest llama-test-202-unused-implicit-optional nil + + (should (equal (##list &2) + (lambda (&optional _&1 &2) + (list &2)))) + + (should (equal (##list &2 &3) + (lambda (&optional _&1 &2 &3) + (list &2 &3)))) + + (should (equal (##list &3) + (lambda (&optional _&1 _&2 &3) + (list &3)))) + + (should (equal (##list &1 &3) + (lambda (&optional &1 _&2 &3) + (list &1 &3)))) + + (should (equal (##list &3 &6) + (lambda (&optional _&1 _&2 &3 _&4 _&5 &6) + (list &3 &6)))) + ) + +(ert-deftest llama-test-203-unused-implicit-mixed nil + + (should (equal (##list %1 &3) + (lambda (%1 &optional _&2 &3) + (list %1 &3)))) + + (should (equal (##list %1 &4) + (lambda (%1 &optional _&2 _&3 &4) + (list %1 &4)))) + + (should (equal (##list %1 %2 &4) + (lambda (%1 %2 &optional _&3 &4) + (list %1 %2 &4)))) + + + (should (equal (##list %2 &4 &6) + (lambda (_%1 %2 &optional _&3 &4 _&5 &6) + (list %2 &4 &6)))) + ) + +(ert-deftest llama-test-301-unused-explicit-trailing nil + + (should (equal (##list _%1) + (lambda (_%1) + (list)))) + + (should (equal (##list _%2) + (lambda (_%1 _%2) + (list)))) + + (should (equal (##list %1 _%2) + (lambda (%1 _%2) + (list %1)))) + + (should (equal (##list %1 _%3) + (lambda (%1 _%2 _%3) + (list %1)))) + ) + +(ert-deftest llama-test-302-unused-explicit-border nil + + (should (equal (##list _%1 &2) + (lambda (_%1 &optional &2) + (list &2)))) + + (should (equal (##list _%2 &3) + (lambda (_%1 _%2 &optional &3) + (list &3)))) + + (should (equal (##list %1 _%2 &3) + (lambda (%1 _%2 &optional &3) + (list %1 &3)))) + + (should (equal (##list %1 _%2 &4) + (lambda (%1 _%2 &optional _&3 &4) + (list %1 &4)))) + + (should (equal (##list %1 _%3 &6) + (lambda (%1 _%2 _%3 &optional _&4 _&5 &6) + (list %1 &6)))) + ) + +(ert-deftest llama-test-303-unused-redundant nil + + (should (equal (##list _%1 %2) + (lambda (_%1 %2) + (list %2)))) + + (should (equal (##list _&1 &2) + (lambda (&optional _&1 &2) + (list &2)))) + ) + +(ert-deftest llama-test-401-abbrev nil + ;; llama-test-101-basic(s/%1/%/) + + (should (equal (##list %) + (lambda (%) + (list %)))) + + (should (equal (##list % %) + (lambda (%) + (list % %)))) + + (should (equal (##list % %2) + (lambda (% %2) + (list % %2)))) + + (should (equal (##list %2 %) + (lambda (% %2) + (list %2 %)))) + + (should (equal (##list 'const %) + (lambda ( %) + (list 'const %)))) + + (should (equal (##list % 'const) + (lambda (%) + (list % 'const)))) + + (should (equal (##list % 'const %2) + (lambda (% %2) + (list % 'const %2)))) + + (should (equal (##list %2 'const %) + (lambda (% %2) + (list %2 'const %)))) + + (should (equal (##list % %2 %3 %4 %5 %6 %7 %8 %9) + (lambda (% %2 %3 %4 %5 %6 %7 %8 %9) + (list % %2 %3 %4 %5 %6 %7 %8 %9)))) + + (should (equal (##list % %2 % %3 %5 %4 %6 %7 %9 %8) + (lambda (% %2 %3 %4 %5 %6 %7 %8 %9) + (list % %2 % %3 %5 %4 %6 %7 %9 %8)))) + ) + +(ert-deftest llama-test-402-abbrev-optional nil + ;; llama-test-102-basic-optional(s/&1/&/) + + (should (equal (##list &1) + (lambda (&optional &1) + (list &1)))) + + (should (equal (##list % &2) + (lambda (% &optional &2) + (list % &2)))) + + (should (equal (##list %2 % &4 &3) + (lambda ( % %2 &optional &3 &4) + (list %2 % &4 &3)))) + ) + +(ert-deftest llama-test-501-function-position nil + + (should (equal (##+ (% %2 2) %1) + (lambda (%1 %2) + (+ (% %2 2) %1)))) + + (should (equal (##+ (* %2 2) %) + (lambda (% %2) + (+ (* %2 2) %)))) + + (should (equal (##% %2 2) + (lambda (_%1 %2) + (% %2 2)))) + + (should (equal (##* %1 2) + (lambda (%1) + (* %1 2)))) + + (should (equal (##% %2 %1) + (lambda (%1 %2) + (% %2 %1)))) + ) + +(defmacro llama-test--flatten (expr) + (when (vectorp expr) + (setq expr (mapcan (lambda (e) + (if (vectorp e) (append e ()) (list e))) + (append expr ())))) + (let ((body ())) + (while expr + (if (listp expr) (push (pop expr) body) (push expr body) (setq expr nil))) + (cons 'list (nreverse body)))) + +(ert-deftest llama-test-502-vector nil + + ;; Real world example: (##-let [val %1] ...). + + (should (equal (##llama-test--flatten [[1 %1]]) + (lambda (%1) + (llama-test--flatten [[1 %1]])))) + + (should (equal (##llama-test--flatten [%2 [%1]]) + (lambda (%1 %2) + (llama-test--flatten [%2 [%1]])))) + + (should (equal (##llama-test--flatten [%1 _%2 %3]) + (lambda (%1 _%2 %3) + (llama-test--flatten [%1 %3])))) + ) + +(ert-deftest llama-test-502-dotted nil + + ;; Real world example: ???. + + (should (equal (##llama-test--flatten (%1 . %2)) + (lambda (%1 %2) + (llama-test--flatten (%1 . %2))))) + + (should (equal (##llama-test--flatten (%1 %2 . %3)) + (lambda (%1 %2 %3) + (llama-test--flatten (%1 %2 . %3))))) + + (should (equal (##llama-test--flatten (%1 _%2 . %3)) + (lambda (%1 _%2 %3) + (llama-test--flatten (%1 . %3))))) + + (should (equal (##llama-test--flatten (%1 _%2 %3 . %4)) + (lambda (%1 _%2 %3 %4) + (llama-test--flatten (%1 %3 . %4))))) + ) + +(ert-deftest llama-test-503-quoted nil + + (should (equal (##cons %1 '(%2)) + (lambda (%1) + (cons %1 '(%2))))) + ) + +(ert-deftest llama-test-504-backquoted nil + + (should (equal (##list `(,%1 %2 ,%3)) + (lambda (%1 _%2 %3) + (list `(,%1 %2 ,%3))))) + + (should (equal (##list `(,%1 %2 (,%3) ,%4 . ,%5)) + (lambda (%1 _%2 %3 %4 %5) + (list `(,%1 %2 (,%3) ,%4 . ,%5))))) + + (should (equal (##`(,%1 %2 ,%3)) + (lambda (%1 _%2 %3) + `(,%1 %2 ,%3)))) + + (should (equal (##`(,%1 %2 (,%3) ,%4 . ,%5)) + (lambda (%1 _%2 %3 %4 %5) + `(,%1 %2 (,%3) ,%4 . ,%5)))) + + (should (equal (##list `(,% ,@% %)) + (lambda (%) + (list `(,% ,@% %))))) + + (should (equal (##list `(% ,%2)) + (lambda (_%1 %2) + (list `(% ,%2))))) + + (should (equal (##list `(,@%1 %2 ,%3 (,@%3 ,%1))) + (lambda (%1 _%2 %3) + (list `(,@%1 %2 ,%3 (,@%3 ,%1)))))) + ) + +(ert-deftest llama-test-701-llama nil + + (should (equal (llama list %1) + (lambda (%1) + (list %1)))) + + (should (equal (llama list %1 %1) + (lambda (%1) + (list %1 %1)))) + + (should (equal (llama list %1 %2) + (lambda (%1 %2) + (list %1 %2)))) + + (should (equal (llama list %1 (llama list %)) + (lambda (%1) + (list %1 (lambda (%) (list %)))))) + ) + +(ert-deftest llama-test-901-errors-first nil + (should-error (##list %1 &1)) + (should-error (##list &1 %1)) + (should-error (##list %1 _%1)) + (should-error (##list _%1 %1)) + (should-error (##list %1 _&1)) + (should-error (##list _&1 %1)) + (should-error (##list %1 %1 &1)) + ) + +(ert-deftest llama-test-801-ambiguity nil + + ;; We cannot know how every special form and macro uses its arguments, + ;; and can therefore not always do the right thing™. However, whatever + ;; we end up doing, font-lock should agree. Here are some noteworthy + ;; examples where our macro expansion and our font-lock agree, but the + ;; author might have intended something else. + + (static-if (>= emacs-major-version 28) ; prevent compiler warnings + (with-no-warnings ; unused arguments + ;; A good example of what we might not want and theoretically could + ;; prevent. However, this can also be prevented by just not going + ;; out of our way to wander into ambiguous territory. While not + ;; impossible, it is unlikely that someone does this accidentally. + (should (equal (##setq % 1) + (lambda (%) + (setq % 1)))) + + ;; We have to fake `-setq' because we don't want to depend on `dash' + ;; and because (equal (lambda () (-setq a 1)) (lambda () (-setq a 1))) + ;; is never true because `-setq' uses `make-symbol'. Mocking that + ;; macro does *not* affect the expansion of `##' into a `lambda'. + (cl-macrolet ((-setq (&rest args) `'(,@args))) + (should (equal (##-setq % 1) + (lambda (%) + (-setq % 1)))) + (should (equal (##-setq (%) '(1)) + (lambda () + (-setq (%) '(1))))) + (should (equal (##-setq [(%)] [(1)]) + (lambda () + (-setq [(%)] [(1)])))) + (should (equal (##-setq [(% %)] [(1 2)]) + (lambda (%) + (-setq [(% %)] [(1 2)])))) + (should (equal (##-setq [(%1)] [(1)]) + (lambda (%1) + (-setq [(%1)] [(1)])))))) + )) + +(ert-deftest llama-test-902-errors-second nil + (should-error (##list %2 &2)) + (should-error (##list &2 %2)) + (should-error (##list %2 _%2)) + (should-error (##list _%2 %2)) + (should-error (##list %2 _&2)) + (should-error (##list _&2 %2)) + (should-error (##list %2 %2 &2)) + ) + +(ert-deftest llama-test-903-errors-abbrev nil + (should-error (##list % &)) + (should-error (##list & %)) + (should-error (##list % _%)) + (should-error (##list _% %)) + (should-error (##list % _&)) + (should-error (##list _& %)) + (should-error (##list % % &)) + (should-error (##list % %1)) + (should-error (##list % _%1)) + (should-error (##list % &1)) + (should-error (##list % _&1)) + (should-error (##list %1 %)) + ) + +(ert-deftest llama-test-904-errors-syntax nil + + ;; ((lambda (%) (+ 1 %)) 2) + ;; results in + ;; Warning: Use of deprecated ((lambda (%) ...) ...) form + ;; but works. + + ;; ((##+ 1 %) 2) + ;; results at compile-time in + ;; Warning: Malformed function ‘(## + 1 %)’ + ;; results at run-time in + ;; Error: invalid-function ((## + 1 %)) + ;; and cannot possibly work. + + ;; Delay macro-expansion for demonstration purposes. + (should-error (eval '((##+ 1 %) 2))) + + ;; This is what one should be doing instead. + (should (equal (funcall (lambda (%) (+ 1 %)) 2) 3)) + (should (equal (funcall (## + 1 %) 2) 3)) + ) + +;; Local Variables: +;; eval: (prettify-symbols-mode -1) +;; indent-tabs-mode: nil +;; End: +;;; llama-tests.el ends here blob - /dev/null blob + c1d6558bf4c4d06d88fcd5dd63b3cf253517b0c2 (mode 644) --- /dev/null +++ elpa/llama-1.0.0/llama.el @@ -0,0 +1,572 @@ +;;; llama.el --- Compact syntax for short lambda -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2025 Jonas Bernoulli + +;; Authors: Jonas Bernoulli +;; Homepage: https://github.com/tarsius/llama +;; Keywords: extensions + +;; Package-Version: 1.0.0 +;; Package-Requires: ((emacs "26.1") (compat "30.1")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; 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 3 of the License, +;; 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 this file. If not, see . + +;;; Commentary: + +;; This package implements a macro named `##', which provides a compact way +;; to write short `lambda' expressions. + +;; The signature of the macro is (## FN &rest BODY) and it expands to a +;; `lambda' expression, which calls the function FN with the arguments BODY +;; and returns the value of that. The arguments of the `lambda' expression +;; are derived from symbols found in BODY. + +;; Each symbol from `%1' through `%9', which appears in an unquoted part +;; of BODY, specifies a mandatory argument. Each symbol from `&1' through +;; `&9', which appears in an unquoted part of BODY, specifies an optional +;; argument. The symbol `&*' specifies extra (`&rest') arguments. + +;; The shorter symbol `%' can be used instead of `%1', but using both in +;; the same expression is not allowed. Likewise `&' can be used instead +;; of `&1'. These shorthands are not recognized in function position. + +;; To support binding forms that use a vector as VARLIST (such as `-let' +;; from the `dash' package), argument symbols are also detected inside of +;; vectors. + +;; The space between `##' and FN can be omitted because `##' is read-syntax +;; for the symbol whose name is the empty string. If you prefer you can +;; place a space there anyway, and if you prefer to not use this somewhat +;; magical symbol at all, you can instead use the alternative name `llama'. + +;; Instead of: +;; +;; (lambda (a &optional _ c &rest d) +;; (foo a (bar c) d)) +;; +;; you can use this macro and write: +;; +;; (##foo %1 (bar &3) &*) +;; +;; which expands to: +;; +;; (lambda (%1 &optional _&2 &3 &rest &*) +;; (foo %1 (bar &3) &*)) + +;; Unused trailing arguments and mandatory unused arguments at the border +;; between mandatory and optional arguments are also supported: +;; +;; (##list %1 _%3 &5 _&6) +;; +;; becomes: +;; +;; (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) +;; (list %1 &5)) +;; +;; Note how `_%3' and `_&6' are removed from the body, because their names +;; begin with an underscore. Also note that `_&4' is optional, unlike the +;; explicitly specified `_%3'. + +;; Consider enabling `llama-fontify-mode' to highlight `##' and its +;; special arguments. + +;;; Code: + +(require 'compat) + +;;;###autoload +(defmacro llama (fn &rest body) + "Expand to a `lambda' expression that wraps around FN and BODY. + +This macro provides a compact way to write short `lambda' expressions. +It expands to a `lambda' expression, which calls the function FN with +arguments BODY and returns its value. The arguments of the `lambda' +expression are derived from symbols found in BODY. + +Each symbol from `%1' through `%9', which appears in an unquoted part +of BODY, specifies a mandatory argument. Each symbol from `&1' through +`&9', which appears in an unquoted part of BODY, specifies an optional +argument. The symbol `&*' specifies extra (`&rest') arguments. + +The shorter symbol `%' can be used instead of `%1', but using both in +the same expression is not allowed. Likewise `&' can be used instead +of `&1'. These shorthands are not recognized in function position. + +To support binding forms that use a vector as VARLIST (such as `-let' +from the `dash' package), argument symbols are also detected inside of +vectors. + +The space between `##' and FN can be omitted because `##' is read-syntax +for the symbol whose name is the empty string. If you prefer you can +place a space there anyway, and if you prefer to not use this somewhat +magical symbol at all, you can instead use the alternative name `llama'. + +Instead of: + + (lambda (a &optional _ c &rest d) + (foo a (bar c) d)) + +you can use this macro and write: + + (##foo %1 (bar &3) &*) + +which expands to: + + (lambda (%1 &optional _&2 &3 &rest &*) + (foo %1 (bar &3) &*)) + +Unused trailing arguments and mandatory unused arguments at the border +between mandatory and optional arguments are also supported: + + (##list %1 _%3 &5 _&6) + +becomes: + + (lambda (%1 _%2 _%3 &optional _&4 &5 _&6) + (list %1 &5)) + +Note how `_%3' and `_&6' are removed from the body, because their names +begin with an underscore. Also note that `_&4' is optional, unlike the +explicitly specified `_%3'. + +Consider enabling `llama-fontify-mode' to highlight `##' and its +special arguments." + (cond ((symbolp fn)) + ((and (eq (car-safe fn) backquote-backquote-symbol) + (not body)) + (setq body (cdr fn)) + (setq fn backquote-backquote-symbol)) + ((signal 'wrong-type-argument + (list 'symbolp backquote-backquote-symbol fn)))) + (let* ((args (make-vector 10 nil)) + (body (cdr (llama--collect (cons fn body) args))) + (rest (aref args 0)) + (args (nreverse (cdr (append args nil)))) + (args (progn (while (and args (null (car args))) + (setq args (cdr args))) + args)) + (pos (length args)) + (opt nil) + (args (mapcar + (lambda (arg) + (if arg + (setq opt (string-match-p "\\`_?&" (symbol-name arg))) + (setq arg (intern (format "_%c%s" (if opt ?& ?%) pos)))) + (setq pos (1- pos)) + arg) + args)) + (opt nil) + (args (mapcar + (lambda (symbol) + (cond + ((string-match-p "\\`_?%" (symbol-name symbol)) + (when opt + (error "`%s' cannot follow optional arguments" symbol)) + (list symbol)) + (opt + (list symbol)) + ((setq opt t) + (list '&optional symbol)))) + (nreverse args)))) + `(lambda + (,@(apply #'nconc args) + ,@(and rest (list '&rest rest))) + (,fn ,@body)))) + +(defalias (intern "") 'llama) +(defalias '\#\# 'llama) + +(defconst llama--unused-argument (make-symbol "llama--unused-argument")) + +(defun llama--collect (expr args &optional fnpos backquoted unquote) + (cond + ((memq (car-safe expr) (list (intern "") 'llama 'quote)) expr) + ((and backquoted (symbolp expr)) expr) + ((and backquoted + (memq (car-safe expr) + (list backquote-unquote-symbol + backquote-splice-symbol))) + (list (car expr) + (llama--collect (cadr expr) args nil nil t))) + ((memq (car-safe expr) + (list backquote-backquote-symbol + backquote-splice-symbol)) + (list (car expr) + (llama--collect (cadr expr) args nil t))) + ((symbolp expr) + (let ((name (symbol-name expr))) + (save-match-data + (cond + ((string-match "\\`\\(_\\)?[%&]\\([1-9*]\\)?\\'" name) + (let* ((pos (match-string 2 name)) + (pos (cond ((equal pos "*") 0) + ((not pos) 1) + ((string-to-number pos)))) + (sym (aref args pos))) + (unless (and fnpos (not unquote) (memq expr '(% &))) + (when (and sym (not (equal expr sym))) + (error "`%s' and `%s' are mutually exclusive" sym expr)) + (aset args pos expr))) + (if (match-string 1 name) + llama--unused-argument + expr)) + (expr))))) + ((or (listp expr) + (vectorp expr)) + (let* ((vectorp (vectorp expr)) + (expr (if vectorp (append expr ()) expr)) + (fnpos (and (not vectorp) + (not backquoted) + (ignore-errors (length expr)))) ;proper-list-p + (ret ())) + (catch t + (while t + (let ((elt (llama--collect (car expr) args fnpos backquoted))) + (unless (eq elt llama--unused-argument) + (push elt ret))) + (setq fnpos nil) + (setq expr (cdr expr)) + (unless (and expr + (listp expr) + (not (eq (car expr) backquote-unquote-symbol))) + (throw t nil)))) + (setq ret (nreverse ret)) + (when expr + (setcdr (last ret) (llama--collect expr args nil backquoted))) + (if vectorp (vconcat ret) ret))) + (expr))) + +;;; Completion + +(define-advice elisp--expect-function-p (:around (fn pos) llama) + "Support function completion directly following `##'." + (or (and (eq (char-before pos) ?#) + (eq (char-before (- pos 1)) ?#)) + (and (eq (char-before pos) ?\s) + (eq (char-before (- pos 1)) ?#) + (eq (char-before (- pos 2)) ?#)) + (funcall fn pos))) + +(define-advice all-completions (:around (fn str table &rest rest) llama) + "Remove empty symbol from completion results if originating from `llama'. + +`##' is the notation for the symbol whose name is the empty string. + (intern \"\") => ## + (symbol-name \\='##) => \"\" + +The `llama' package uses `##' as the name of a macro, which allows +it to be used akin to syntax, without actually being new syntax. +\(`describe-function' won't let you select `##', but because that is an +alias for `llama', you can access the documentation under that name.) + +This advice prevents the empty string from being offered as a completion +candidate when `obarray' or a completion table that internally uses +that is used as TABLE." + (let ((result (apply fn str table rest))) + (if (and (eq obarray table) (equal str "")) + (delete "" result) + result))) + +;;; Fontification + +(defgroup llama () + "Compact syntax for short lambda." + :group 'extensions + :group 'faces + :group 'lisp) + +(defface llama-\#\#-macro '((t :inherit font-lock-function-call-face)) + "Face used for the name of the `##' macro.") + +(defface llama-llama-macro '((t :inherit font-lock-keyword-face)) + "Face used for the name of the `llama' macro.") + +(defface llama-mandatory-argument '((t :inherit font-lock-variable-use-face)) + "Face used for mandatory arguments `%1' through `%9' and `%'.") + +(defface llama-optional-argument '((t :inherit font-lock-type-face)) + "Face used for optional arguments `&1' through `&9', `&' and `&*'.") + +(defface llama-deleted-argument + `((((supports :box t)) + :box ( :line-width ,(if (>= emacs-major-version 28) (cons -1 -1) -1) + :color "red" + :style nil)) + (((supports :underline t)) + :underline "red") + (t + :inherit font-lock-warning-face)) + "Face used for deleted arguments `_%1'...`_%9', `_&1'...`_&9' and `_&*'. +This face is used in addition to one of llama's other argument faces. +Unlike implicit unused arguments (which do not appear in the function +body), these arguments are deleted from the function body during macro +expansion, and the looks of this face should hint at that.") + +(defconst llama-font-lock-keywords-28 + '(("(\\(##\\)" 1 'llama-\#\#-macro) + ("(\\(llama\\)\\_>" 1 'llama-llama-macro) + ("\\_<\\(?:_?%[1-9]?\\)\\_>" + 0 (llama--maybe-face 'llama-mandatory-argument)) + ("\\_<\\(?:_?&[1-9*]?\\)\\_>" + 0 (llama--maybe-face 'llama-optional-argument)) + ("\\_<\\(?:_\\(?:%[1-9]?\\|&[1-9*]?\\)\\)\\_>" + 0 'llama-deleted-argument prepend))) + +(defconst llama-font-lock-keywords-29 + `(("\\_<\\(&[1-9*]?\\)\\_>" 1 'default) + (,(apply-partially #'llama--match-and-fontify "(\\(##\\)") + 1 'llama-\#\#-macro) + (,(apply-partially #'llama--match-and-fontify "(\\(llama\\_>\\)") + 1 'llama-llama-macro))) + +(defvar llama-font-lock-keywords + (if (fboundp 'read-positioning-symbols) + llama-font-lock-keywords-29 + llama-font-lock-keywords-28)) + +(defun llama--maybe-face (face) + (and (not (and (member (match-string 0) '("%" "&")) + (and-let* ((beg (ignore-errors + (scan-lists (match-beginning 0) -1 1)))) + (string-match-p "\\`\\(##\\|llama\\_>\\)?[\s\t\n\r]*\\'" + (buffer-substring-no-properties + (1+ beg) (match-beginning 0)))))) + face)) + +(defun llama--match-and-fontify (re end) + (static-if (fboundp 'bare-symbol) + (and (re-search-forward re end t) + (prog1 t + (save-excursion + (goto-char (match-beginning 0)) + (when-let (((save-match-data (not (nth 8 (syntax-ppss))))) + (expr (ignore-errors + (read-positioning-symbols (current-buffer))))) + (put-text-property (match-beginning 0) (point) + 'font-lock-multiline t) + (llama--fontify (cdr expr) nil nil t))))) + (list re end))) ; Silence compiler. + +(defun llama--fontify (expr &optional fnpos backquoted top) + (static-if (fboundp 'bare-symbol) + (cond + ((null expr) expr) + ((eq (car-safe expr) 'quote)) + ((eq (ignore-errors (bare-symbol (car-safe expr))) 'quote)) + ((and (memq (ignore-errors (bare-symbol (car-safe expr))) + (list (intern "") 'llama)) + (not top))) + ((and backquoted (symbol-with-pos-p expr))) + ((and backquoted + (memq (car-safe expr) + (list backquote-unquote-symbol + backquote-splice-symbol))) + (llama--fontify expr)) + ((symbol-with-pos-p expr) + (save-match-data + (when-let* + ((name (symbol-name (bare-symbol expr))) + (face (cond + ((and (string-match + "\\_<\\(?:\\(_\\)?%\\([1-9]\\)?\\)\\_>" name) + (or (not fnpos) (match-end 2))) + 'llama-mandatory-argument) + ((and (string-match + "\\_<\\(?:\\(_\\)?&\\([1-9*]\\)?\\)\\_>" name) + (or (not fnpos) (match-end 2))) + 'llama-optional-argument)))) + (when (match-end 1) + (setq face (list 'llama-deleted-argument face))) + (let ((beg (symbol-with-pos-pos expr))) + (put-text-property + beg (save-excursion (goto-char beg) (forward-symbol 1)) + 'face face))))) + ((or (listp expr) + (vectorp expr)) + (let* ((vectorp (vectorp expr)) + (expr (if vectorp (append expr ()) expr)) + (fnpos (and (not vectorp) + (not backquoted) + (ignore-errors (length expr))))) + (catch t + (while t + (cond ((eq (car expr) backquote-backquote-symbol) + (setq expr (cdr expr)) + (llama--fontify (car expr) t t)) + ((llama--fontify (car expr) fnpos backquoted))) + (setq fnpos nil) + (setq expr (cdr expr)) + (unless (and expr + (listp expr) + (not (eq (car expr) backquote-unquote-symbol))) + (throw t nil)))) + (when expr + (llama--fontify expr fnpos)))))) + (list expr fnpos backquoted top)) ; Silence compiler. + +(defvar llama-fontify-mode-lighter nil) + +;;;###autoload +(define-minor-mode llama-fontify-mode + "In Emacs Lisp mode, highlight the `##' macro and its special arguments." + :lighter llama-fontify-mode-lighter + :global t + (cond + (llama-fontify-mode + (advice-add 'lisp--el-match-keyword :override + #'lisp--el-match-keyword@llama '((depth . -80))) + (advice-add 'elisp-mode-syntax-propertize :override + #'elisp-mode-syntax-propertize@llama) + (add-hook 'emacs-lisp-mode-hook #'llama--add-font-lock-keywords)) + (t + (advice-remove 'lisp--el-match-keyword + #'lisp--el-match-keyword@llama) + (advice-remove 'elisp-mode-syntax-propertize + #'elisp-mode-syntax-propertize@llama) + (remove-hook 'emacs-lisp-mode-hook #'llama--add-font-lock-keywords))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'emacs-lisp-mode) + (if llama-fontify-mode + (font-lock-add-keywords nil llama-font-lock-keywords) + (font-lock-remove-keywords nil llama-font-lock-keywords)) + (font-lock-flush))))) + +(defun llama--add-font-lock-keywords () + (font-lock-add-keywords nil llama-font-lock-keywords)) + +(define-obsolete-function-alias 'global-llama-fontify-mode + #'llama-fontify-mode "Llama 0.6.2") + +(defun lisp--el-match-keyword@llama (limit) + "Highlight symbols following \"(##\" the same as if they followed \"(\"." + (catch 'found + (while (re-search-forward + (concat "(\\(?:## ?\\)?\\(" + (static-if (get 'lisp-mode-symbol 'rx-definition) ;>= 29.1 + (rx lisp-mode-symbol) + lisp-mode-symbol-regexp) + "\\)\\_>") + limit t) + (let ((sym (intern-soft (match-string 1)))) + (when (and (or (special-form-p sym) + (macrop sym) + (and (bound-and-true-p morlock-mode) + ;; Same as in advice of `morlock' package. + (get sym 'morlock-font-lock-keyword))) + (not (get sym 'no-font-lock-keyword)) + (static-if (fboundp 'lisp--el-funcall-position-p) ;>= 28.1 + (lisp--el-funcall-position-p (match-beginning 0)) + (not (lisp--el-non-funcall-position-p + (match-beginning 0))))) + (throw 'found t)))))) + +(defun elisp-mode-syntax-propertize@llama (start end) + ;; Synced with Emacs up to 6b9510d94f814cacf43793dce76250b5f7e6f64a. + "Highlight `##' as the symbol which it is." + (goto-char start) + (let ((case-fold-search nil)) + (funcall + (syntax-propertize-rules + ;; Empty symbol. + ;; {{ Comment out to prevent the `##' from becoming part of + ;; the following symbol when there is no space in between. + ;; ("##" (0 (unless (nth 8 (syntax-ppss)) + ;; (string-to-syntax "_")))) + ;; }} + ;; {{ As for other symbols, use `font-lock-constant-face' in + ;; docstrings and comments. + ("##" (0 (when (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ;; }} + ;; {{ Preserve this part, even though it is absent from + ;; this function in 29.1; backporting it by association. + ;; Prevent the @ from becoming part of a following symbol. + (",@" (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "'")))) + ;; }} + ;; Unicode character names. (The longest name is 88 characters + ;; long.) + ("\\?\\\\N{[-A-Za-z0-9 ]\\{,100\\}}" + (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ((rx "#" (or (seq (group-n 1 "&" (+ digit)) ?\") ; Bool-vector. + (seq (group-n 1 "s") "(") ; Record. + (seq (group-n 1 (+ "^")) "["))) ; Char-table. + (1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "'"))))) + start end))) + +;;; Partial applications + +(defun llama--left-apply-partially (fn &rest args) + "Return a function that is a partial application of FN to ARGS. + +ARGS is a list of the first N arguments to pass to FN. The result +is a new function which does the same as FN, except that the first N +arguments are fixed at the values with which this function was called. + +See also `llama--right-apply-partially', which instead fixes the last +N arguments. + +These functions are intended to be used using the names `partial' and +`rpartial'. To be able to use these shorthands in a file, you must set +the file-local value of `read-symbols-shorthands', which was added in +Emacs 28.1. For an example see the end of file \"llama.el\". + +This is an alternative to `apply-partially', whose name is too long." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args2) + (apply fn (append args args2)))) + +(defun llama--right-apply-partially (fn &rest args) + "Return a function that is a right partial application of FN to ARGS. + +ARGS is a list of the last N arguments to pass to FN. The result +is a new function which does the same as FN, except that the last N +arguments are fixed at the values with which this function was called. + +See also `llama--left-apply-partially', which instead fixes the first +N arguments. + +These functions are intended to be used using the names `rpartial' and +`partial'. To be able to use these shorthands in a file, you must set +the file-local value of `read-symbols-shorthands', which was added in +Emacs 28.1. For an example see the end of file \"llama.el\"." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args2) + (apply fn (append args2 args)))) + +;; An example of how one would use these functions: +;; +;; (list (funcall (partial (lambda (a b) (list a b)) 'fixed) 'after) +;; (funcall (rpartial (lambda (a b) (list a b)) 'fixed) 'before)) + +;; An example of the configuration that is necessary to enable this: +;; +;; Local Variables: +;; indent-tabs-mode: nil +;; read-symbol-shorthands: ( +;; ("partial" . "llama--left-apply-partially") +;; ("rpartial" . "llama--right-apply-partially")) +;; End: +;; +;; Do not set `read-symbol-shorthands' in the ".dir-locals.el" +;; file, because that does not work for uncompiled libraries. + +(provide 'llama) + +;;; llama.el ends here blob - /dev/null blob + d58bd4c9362cb2bb7458571f62ac876ab5735712 (mode 644) --- /dev/null +++ elpa/llama-1.0.0.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2025-07-04T11:10:27+0200 using EDDSA \ No newline at end of file blob - /dev/null blob + ea760dc2f3ce0f086e8bfc5f087b83d549294683 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/.dir-locals.el @@ -0,0 +1,15 @@ +((nil + (indent-tabs-mode . nil)) + (makefile-mode + (indent-tabs-mode . t) + (outline-regexp . "#\\(#+\\)") + (mode . outline-minor)) + (emacs-lisp-mode + (checkdoc-allow-quoting-nil-and-t . t)) + (git-commit-mode + (git-commit-major-mode . git-commit-elisp-text-mode)) + (".github/PULL_REQUEST_TEMPLATE" + (nil (truncate-lines . nil))) + ("CHANGELOG" + (nil (fill-column . 70) + (mode . display-fill-column-indicator)))) blob - /dev/null blob + c5981c0a7e4302f378866bc35ddf3a3d37e9cc10 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/CHANGELOG @@ -0,0 +1,446 @@ +# -*- mode: org -*- +* v4.3.8 2025-07-05 + +Bugfixes: + +- In v4.3.7 we started to restore the display-start positions of the + windows displaying a buffer that is being refreshed, but in log + buffers that is undesirable. After creating a new commit we want + that to immediately be displayed at the top of windows displaying + log buffers. #5403 + +- Refreshing was skipped after discarding all untracked files. + +- When sub-directories contain ".gitignore" files, then invoking + ~magit-discard~ on the "Untracked files" section did not necessarily + remove the same set of files as listed in that section. (At least + it did show the files, which would be removed, in the confirmation + prompt.) #5405 + +* v4.3.7 2025-07-01 + +- Refreshing a buffer causes its content to be recreated, which can + result in scrolling. Now we attempt to restore the display-start + positions of the windows displaying the buffer. #5403 + +- When running ~git~ for side-effects and that signals an error, we + did not augment the error message to inform the user that the full + output can be found in the process buffer. When the error is not + signaled, we did already append that hint to the message. Also + added a new option, ~magit-show-process-buffer-hint~, for people who + are already aware of the process buffer and would like to avoid + the noisy reminder. #5396 + +Bugfixes: + +- Some instructions inserted into rebase sequence buffers were not + prefixed with ~comment-start~, instead # was used unconditionally. + #5388 + +- Fixed a regression in v4.3.6, which caused a conflict between the + overlays used for section highlighting and section selection, if + both of these faces relied on the same face property (likely the + foreground color). #5389 + +- Hunks could remain painted as selected when navigating away. #5393 + +- The log arguments "--grep" and "--graph" are no longer mutually + exclusive, but we still dropped the latter when the former was + used. #5391 + +- ~magit-save-repository-buffers~ errored on older Emacs releases, + if the value of the variable by the same name is ~ask~. #5399 + +- ~magit-after-save-refresh-status~ did not honor ~magit-inhibit-refresh~. + d9d2f6c312 + +* v4.3.6 2025-06-01 + +- Generalized and heavily refactored the code, previously used only to + highlight diff-related sections and to paint hunks, so that it can + be used for other sections as well. The new implementation should + also be a bit faster. cfe4faaaf6^..c556fee1bd + +- A single-section selection now requires a non-empty region. + 6c4c16942a + +- When creating a stash, "On : " is now offered as a second + future history element. 75c6191999, 9b81df36b4 + +- Added new commands ~git-rebase-drop~, ~git-rebase-alter~ and + ~git-rebase-squish~. 479c467080, 9674c4755a + +Bugfixes: + +- Fixed issues concerning date handling in log margins. #5373 + +- The list of rebase actions in the status buffer could contain + invalid elements derived from comments in Git's list of such + actions. 91806dc729 + +- Applying the region used to fail, if some part of the same hunk but + outside the region has conflicts, even if the part in the region did + not. 9e551d9eb7 + +* v4.3.5 2025-05-14 + +Bugfixes: + +- Fixed a v4.3.3 regression in inserting rebase actions into the + status buffer when stopping at the last commit. #5365 + +* v4.3.4 2025-05-13 + +- Arguments, that are normally set by cycling through the possible + values displayed in the menu, can now also be set using completion, + by using a prefix argument. #5362 + +Bugfixes: + +- Matching references were no longer displayed on the first line of + revision buffers. 48b158500d + +- Fixed a v4.3.3 regression in inserting rebase actions into the + status buffer when ~--rebase-merges~ is specified. #5365 + +- On the "Untracked files" section, ~k~ no longer worked as intended. + #5366 + +Also contains code and documentation cleanups and improvements. + +* v4.3.3 2025-05-01 + +- ~magit-section-show-level~ now acts on all selected sections. #5354 + +- Inserting the list of commits being rebased into the status buffer + is now much faster. 8e72767262 + +- All rebase actions are now inserted into the status buffer. + 69b310e109 + +- While editing the list of commits and actions to be rebased + ~git-rebase-kill-line~ (~k~) on a commented line now uncomments it. + ff44ee1bc3 + +- Added new variants of commands that deal with files for use in Dired + buffers, and improved existing variants. In Dired, these commands + are available from ~magit-file-dispatch~ (~C-c M-g~). 542c2f8a75 et al. + +- ~magit-branch-shelve~ now prepends the date to the refname, and + ~magit-branch-unshelve~ removes such prefixes. 78ffd1a389 + +- The new function ~magit-insert-shelved-branch~ can be added to + ~magit-refs-sections-hook~ to list shelved branches. d6b7784547 + +- Added new command ~magit-wip-purge~, which removes old branches + created by ~magit-wip-mode~. d5e0f3a639 + +- ~magit-blame-styles~ now supports inserting truncated commit hashes. + #4057 + +- Added new command ~magit-mouse-set-point~. 3c9e519197 + +Also contains code and documentation cleanups and improvements. + +* v4.3.2 2025-04-01 + +- Removed legacy options ~magit-wip-*-mode-lighter~. 225ea6fd00 + +- ~magit-log-current~ now falls back to displaying the log for ~HEAD~ if + no branch is checked out, and the now redundant ~magit-log-head~ is + no longer displayed in the ~magit-log~ menu by default. c8b1e12bd5 + +- Renamed ~magit-merge-into~ to ~magit-merge-dissolve~ and changed the + key binding in the ~magit-merge~ menu from ~i~ to ~d~. The description + in that menu already was "dissolve". Do this to make it more + obvious that this command deletes the source branch after it has + been merged into the target branch. #4386 + +- Added new option ~magit-process-apply-ansi-colors~ (but discourage + its use). #5348 + +- Support for Ido has been moved out into a new package ~magit-ido~. + 6aec967ee4 + +Bugfixes: + +- ~magit-after-save-refresh-buffers~ did not respect + ~magit-inhibit-refresh~. c0a8e694b9 + +- When washing of a section was delayed and it ends in an empty line, + that line was not always made part of the section. f6f25e6566 + +- In some cases section specific key bindings were not made available + as intended. 6ce1ece580, 3f79700f1b + +- In some cases ~magit-toggle-buffer-lock~ has to uniquify buffer names + but failed to do so. #5330 + +- After applying a hunk, the buffer was refreshed twice. #5343 + +- The diff shown by ~magit-diff-paths~ was not washed. #5093 + +Also contains more code and documentation cleanups and improvements. + +* v4.3.1 2025-03-02 + +- Added new option ~magit-format-file-function,~ and two functions to + optionally prefix file names with icons, with the help of either + ~all-the-icons~ or ~nerd-icons~. #5308 + +- Added new commands ~magit-previous-reference~ and ~magit-next-reference~, + with entry point ~C-c C-r~. Enable ~repeat-mode~ to keep navigating with + ~p~ and ~n~. #5310 + +Bugfixes: + +- ~magit-commit-revise~ failed if no arguments were used. #5306 + +- Some arguments were missing from diff menus when invoked from + the status buffer. #5309 + +- In some menus the bindings for ~--signoff~ conflicted with those for + other arguments. #5312 + +- Fixed unlikely issue in ~magit-git-mergetool~. 66e3ddffe4 + +- Unknown Git trailers resulted in a display error while writing + commit messages. 8c27c910ca + +- When the word at point matched the name of a branch, that was + unconditionally treated as the commit-at-point. This should only be + done when that word is shown using an appropriate face. 2b3f2cb9ad + +- Fixed bug in ~magit-section-cycle-diffs~. #5319 + +- ~magit-stage-untracked~ was a bit fragile. #5325 + +* v4.3.0 2025-02-04 + +- Added new option ~magit-refs-show-branch-descriptions~. 42ed6c1966 + +- When a stash cannot be applied using the trivial method, the user is + offered some fallback methods. The presentation of those has been + improved. #5253 a08b4dd513 + +- Added new hook options ~magit-revision-wash-message-hook~ and + ~magit-log-wash-summary-hook~, and populate them with new and + existing highlighting functions, making it easier to remove default + highlighting and to add custom highlighting. This also increases + consistency between how commit summaries are shown in logs and when + displaying complete commit messages. f54fce0ecc..b86fe009e2 + +- ~amend!~ markers are now highlighted like ~fixup!~ and ~squash!~ markers. + #5261 + +- ~magit-commit-create~ no longer amends to HEAD when called with a + prefix argument. The ~magit-commit~ menu offers four amend commands. + That should be good enough. 5e60aa72e5 + +- ~magit-commit~ no longer features the obscure ~magit-commit-reshelve~ by + default, but it can quickly be reinstated, using the level mechanism. + 20eb323b47 + +- Added new commands ~magit-commit-alter~ and ~magit-commit-revise~, + completing the already extensive set of "fixup" commands. #5261 + +- Improved commit menu, documentation and implementation details. + #5261 + +- The branch at point is detected in more contexts now, i.e., when + there is not actually a branch at point, but one can unambiguously + be derived from the thing at point. 4876f1921e + +- Reworked ~magit-process-password-prompt-regexps~ to be more permissive + and better structured. Hopefully that means we have to extend it + less frequently going forward, when users run into new prompts. + #5288 + +- Speed up listing untracked files in the status buffer, simplify how + the list is configured, and give up on optionally using a tree. + #5284 + +- Argument ~--signoff~ is now available in all menus that create commits. + However, it is no longer shown in any menu by default. See the end + of [[https://magit.vc/manual/transient/Enabling-and-Disabling-Suffixes.html][Enabling and Disabling Suffixes]] to learn how to enable it in all + menus at once in a single action. #5297 + +- Began using the ~##~ macro from the ~llama~ package. 0a64982100 + +- Stopped depending on the ~dash~ package. e40e8f1994 + +Bug fixes: + +- When applying a stash, it was not always discovered when the trivial + method was unsuccessful, and so the user was not offered the use of + a fallback method. #5253 929eb4dca5 + +- ~git-commit.el~ did not require ~magit-process~, which was only a + problem when it is loaded without also loading the rest of Magit. + #5280. + +- The use of an external diff drivers was not prevented in some + places. #5282 + +- ~magit-blame-maybe-show-message~ did not protect against interpreting + % in commit messages as %-specs. d0e795f423 + +- Parts of commit message headers lost the intended background color. + 46c3d8b0ad + +- The confirmation prompt of ~magit-worktree-delete~ failed to name the + affected worktree. #5286 + +- The wrong suffix color was used for ~magit-commit-absorb~ and + ~magit-commit-autofixup~. bfadd41079 + +- ~magit-stash-index~ did not use ~magit-stash-read-message-function~. + #5295 + +- Fixed an error that occurred when creating ~magit-hunk-section-map~ + and the user has disabled ~smerge-command-prefix~. The same bug + exists in Emacs since 29.1, so this will only help users stuck + on Emacs 28. #5300 + +- When the value of a diff or log menu was being initialized from the + arguments in the current buffer and the diff/log was already limited + to a set of files, then all other arguments were discarded. #5304 + +* v4.2.0 2025-01-01 + +- At least Git 2.25.0 is required now. 033a0c0cdc + +- At least Emacs 27.1 is required now. c1a86066e8 + +- Added new command ~magit-toggle-profiling~. f637dd1877 + +- Added new command ~magit-toggle-subprocess-record~. ec1f403af1 + +Bug fixes: + +- Fixed a regression in ~transient-init-value~. 5b4c4aea1b + +- Fixed setting ~fill-paragraph-function~ in + ~git-commit-setup-changelog-support~. 139e0fcff3 + +- ~magit-log-refresh~ lacked the ~--since~ and ~--until~ arguments, which + were already available in ~magit-log~. 3ecebe8d11 + +- Enabling verbose output in ~magit-commit-absorb~ caused an error. + #5272 + +- In logs, no longer strip ~heads/~ prefix from branch names if a tag + with the same name exists. 5cb3492464 + +- ~magit-list-special-refnames~ returned nonsense. #5277 + +* v4.1.3 2024-12-06 + +- For most important sections, if an error occurs while inserting the + section, the error message is now displayed in the section body. + #5255 + +- ~magit-submodule-populate~ now supports ~--recursive~. #5191 #5256 + +- Improved ~magit-process-password-prompt-regexps~. #5257 + +Bug fixes: + +- ~magit-stash-pop~ and ~magit-stash-apply~ sometimes installed conflicts + for the user to resolve that are more complicated than they need to + be. #5253 + +- ~magit-stash-push~ placed ~--~ before other arguments. #5260 + +- ~magit-autorevert~ failed to require ~magit-process~. #5263 + +* v4.1.2 2024-11-02 + +- Add various minor process logging improvements: + 5b30c05d3a magit--git-insert: Collapse process section if appropriate + b11524120e magit--git-insert: Optionally always log to process buffer + cd6cf89d6a Use different face for debug-only process sections + bba06845de magit-process-insert-section: Improve file-path comparison + f2a6133443 magit-run-git-async: No longer clutter ~*Messages*~ buffer + +Bug fixes: + +- If the left margin was in use before ~magit-blame-mode~ started using + that margin, then the old width was not restored when the mode was + disabled. #5236 + +- Prior to Tramp being loaded, setting ~magit-tramp-pipe-stty-settings~ + to ~nil~ resulted in an error, due to ~tramp-pipe-stty-settings~ not + being bound yet. #5240 + +- ~magit-copy-section-value~ no longer did anything for most section + types. #5244. + +- Global git arguments often got added twice to the list of arguments + ultimately passed to git. 914285a5e8 + +- Inserting the headers of status buffers involves temporary changes + to ~magit-insert-section-hook~. These changes were not restricted to + the current buffer, causing errors when ~magit-git-debug~ is enabled + and we thus insert sections in the process buffer, while the status + buffer is being refreshed. 11e13640c4 + +- Some ~git~ errors were not logged despite ~magit-git-debug~ being + enabled. 874fb0fede + +- ~magit-browse-thing~ and ~magit-visit-thing~ tried to turn anything + at point into an URL. Now the bail if there is no URL at point. + 7c842b8ac0 + +* v4.1.1 2024-10-01 + +- Avoid unnecessary work when ~auto-revert-remote-files~ is ~nil~. #5222 + +- Improved default choice offered by ~magit-branch-reset~ and + ~magit-reset-*~. #5230 + +Bug fixes: + +- Added a workaround for a regression in Git v2.46.0. #5212 + +- Section-specific bindings were removed when a section was expanded + whose body is not inserted until the expansion takes place. + 9395de2c94 + +- Addressed an incompatibility with Eglot. #5226 + +- Adapted to a change in ~define-globalized-minor-mode~ in Emacs 30, + which caused ~diff-hl-mode~ to be enabled in blob buffers. #5229 + +- When adding the commit at point to the completion defaults, it was + assumed that ~minibuffer-default-add-function~ cannot be nil. + 6d0075f523 + +- ~magit-blame--format-string-1~ didn't handle a list of faces + correctly. 5395798301 + +- Addressed an incompatibility with Indent-Bars. #5233 + +* v4.1.0 2024-09-01 + +- The library ~git-commit.el~ is no longer distributed as a separate + package, ~git-commit~, but as part of the ~magit~ package. + +- Improved ~magit-tag-release~'s consistency and handling of arguments. + #5102 + +- Updated tooling and other housekeeping. + +Bug fixes: + +- Only use an explicit range in ~magit-insert-recent-commits~, when also + using ~--graph~. With ~--graph~ it increases performance noticeably, + but without it decreases performance somewhat. #5075 + +- ~magit-completing-read-multiple~ now shows the default choice in the + prompt, if a completion framework is used, for which that is useful. + #5205. + +* Older releases + +See ~docs/RelNotes/~. blob - /dev/null blob + afd566910ee9585a5ac0e4737a27f2a1ce3f6cfe (mode 644) --- /dev/null +++ elpa/magit-4.3.8/README.md @@ -0,0 +1,145 @@ +
+

A Git Porcelain inside Emacs

+

+ homepage | + manual | + faq | + wiki | + mastodon +

+
+ +

+ Magit is an interface to the version control system + Git, implemented as an + Emacs package. + Magit aspires to be a complete Git porcelain. While we cannot + (yet) claim that Magit wraps and improves upon each and every Git + command, it is complete enough to allow even experienced Git users + to perform almost all of their daily version control tasks directly + from within Emacs. While many fine Git clients exist, only Magit + and Git itself deserve to be called porcelains. +

+
+ +
+ Keeping its users this excited is + + a lot of work + . + If Magit makes you
more productive too, + then please consider making a donation. +
+
+ Thank you! — Jonas Bernoulli +
+
+
+ + Sponsor my work using Github Sponsors +    + + Sponsor my work using Liberapay +
+ + Sponsor my work using Opencollective +    + + Sponsor my work using PayPal +
+
+
+ Some alternative donation methods are available. +
+
+ +### Getting Started + +If you are new to Magit, then either one of the following two +articles should help understanding how it differs from other Git +clients. + +#### [Visual Magit walk-through](https://emacsair.me/2017/09/01/magit-walk-through) + +If you are completely new to Magit, then this article is a good +visual introduction. + +Almost everything that you see in Magit can be acted on by pressing +some key, but that's not obvious from just seeing how Magit looks. +The screenshots and accompanying text of this article explain how to +perform a variety of actions on Magit's output. + +#### [Magit, the magical Git interface](https://emacsair.me/2017/09/01/the-magical-git-interface) + +Magit differs significantly from other Git interfaces, and its +advantages are not immediately obvious simply from looking at a few +screenshots as presented in the preceding article. + +This article discusses Magit's properties in somewhat more abstract +terms. + +#### Video introductions + +If you prefer [video](https://magit.vc/screencasts/) introductions, +head over to that page, where find a collection of such introductions +and other videos about Magit, by various creators. + +*** +### Support and Contributing + +Magit has many users and very few maintainers, so we kindly ask to read +the appropriate guidelines before getting in contact. — Thanks! + +- 🆘 [How to ask for help](https://github.com/magit/magit/discussions/4630) +- 🪳 [How to report a bug](https://github.com/magit/magit/wiki/How-to-report-a-bug) +- 💡 [How to suggest a feature](https://github.com/magit/magit/discussions/4631) +- 🏗️ [Pull request guidelines](https://github.com/magit/magit/wiki/Pull-request-guidelines) +- ℹ️ [FAQ](https://magit.vc/manual/magit/FAQ.html) +- ℹ️ [Manual](https://magit.vc/manual/magit) + +TL;DR We now use discussions for feature requests (not issues) and prefer +if you ask the community for support instead of the overworked maintainers. + +Please also consider to contribute by supporting other users or by making +a [monetary donation](https://magit.vc/donate). — Thanks! + +*** +### Acknowledgments + +Magit was started by [Marius Vollmer][marius], and is now maintained by +[Jonas Bernoulli][jonas] and [Kyle Meyer][kyle]. Former maintainers are +[Nicolas Dudebout][nicolas], [Noam Postavsky][noam], +[Peter J. Weisberg][peter], [Phil Jackson][phil], [Rémi Vanicat][remi] and +[Yann Hodique][yann]. Many more people have [contributed code][authors], +suggested features or made monetary contributions. + +Thanks to all of you, may (the history of) the source be with you! + +*** +[![Compile](https://github.com/magit/magit/actions/workflows/compile.yml/badge.svg)](https://github.com/magit/magit/actions/workflows/compile.yml) +[![Test](https://github.com/magit/magit/actions/workflows/test.yml/badge.svg)](https://github.com/magit/magit/actions/workflows/test.yml) +[![Manual](https://github.com/magit/magit/actions/workflows/manual.yml/badge.svg)](https://github.com/magit/magit/actions/workflows/manual.yml) +[![NonGNU ELPA](https://emacsair.me/assets/badges/nongnu-elpa.svg)](https://elpa.nongnu.org/nongnu/magit.html) +[![Melpa](https://melpa.org/packages/magit-badge.svg)](https://melpa.org/#/magit) +[![Melpa Stable](https://stable.melpa.org/packages/magit-badge.svg)](https://stable.melpa.org/#/magit) + +[![Packaging status](https://repology.org/badge/vertical-allrepos/emacs%3Amagit.svg?header=&columns=4&minversion=4&exclude_unsupported=1)](https://repology.org/project/emacs%3Amagit/versions) + +[authors]: https://magit.vc/stats/magit/authors.html +[jonas]: https://emacsair.me +[kyle]: https://kyleam.com +[marius]: https://github.com/mvollmer +[nicolas]: http://dudebout.com +[noam]: https://github.com/npostavs +[peter]: https://github.com/pjweisberg +[phil]: https://github.com/philjackson +[remi]: https://github.com/vanicat +[yann]: https://yann.hodique.info blob - /dev/null blob + dfdbd715cf053b551d55387f7e6a10a09fc62213 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* Magit: (magit). Using Git from Emacs with Magit. blob - /dev/null blob + 206cef889af38b67f67cc93d2f24f08c2b3b467e (mode 644) --- /dev/null +++ elpa/magit-4.3.8/git-commit.el @@ -0,0 +1,1224 @@ +;;; git-commit.el --- Edit Git commit messages -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Sebastian Wiesner +;; Florian Ragwitz +;; Marius Vollmer +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, +;; or (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;; You should have received a copy of the AUTHORS.md file, which +;; lists all contributors. If not, see https://magit.vc/authors. + +;;; Commentary: + +;; This package assists the user in writing good Git commit messages. + +;; While Git allows for the message to be provided on the command +;; line, it is preferable to tell Git to create the commit without +;; actually passing it a message. Git then invokes the `$GIT_EDITOR' +;; (or if that is undefined `$EDITOR') asking the user to provide the +;; message by editing the file ".git/COMMIT_EDITMSG" (or another file +;; in that directory, e.g., ".git/MERGE_MSG" for merge commits). + +;; When `global-git-commit-mode' is enabled, which it is by default, +;; then opening such a file causes the features described below, to +;; be enabled in that buffer. Normally this would be done using a +;; major-mode but to allow the use of any major-mode, as the user sees +;; fit, it is done here by running a setup function, which among other +;; things turns on the preferred major-mode, by default `text-mode'. + +;; Git waits for the `$EDITOR' to finish and then either creates the +;; commit using the contents of the file as commit message, or, if the +;; editor process exited with a non-zero exit status, aborts without +;; creating a commit. Unfortunately Emacsclient (which is what Emacs +;; users should be using as `$EDITOR' or at least as `$GIT_EDITOR') +;; does not differentiate between "successfully" editing a file and +;; aborting; not out of the box that is. + +;; By making use of the `with-editor' package this package provides +;; both ways of finish an editing session. In either case the file +;; is saved, but Emacseditor's exit code differs. +;; +;; C-c C-c Finish the editing session successfully by returning +;; with exit code 0. Git then creates the commit using +;; the message it finds in the file. +;; +;; C-c C-k Aborts the edit editing session by returning with exit +;; code 1. Git then aborts the commit. + +;; Aborting the commit does not cause the message to be lost, but +;; relying solely on the file not being tampered with is risky. This +;; package additionally stores all aborted messages for the duration +;; of the current session (i.e., until you close Emacs). To get back +;; an aborted message use M-p and M-n while editing a message. +;; +;; M-p Replace the buffer contents with the previous message +;; from the message ring. Of course only after storing +;; the current content there too. +;; +;; M-n Replace the buffer contents with the next message from +;; the message ring, after storing the current content. + +;; Support for inserting Git trailers (as described in the manpage +;; git-interpret-trailers(1)) is available. +;; +;; C-c C-i Insert a trailer selected from a transient menu. + +;; When Git requests a commit message from the user, it does so by +;; having her edit a file which initially contains some comments, +;; instructing her what to do, and providing useful information, such +;; as which files were modified. These comments, even when left +;; intact by the user, do not become part of the commit message. This +;; package ensures these comments are propertizes as such and further +;; prettifies them by using different faces for various parts, such as +;; files. + +;; Finally this package highlights style errors, like lines that are +;; too long, or when the second line is not empty. It may even nag +;; you when you attempt to finish the commit without having fixed +;; these issues. The style checks and many other settings can easily +;; be configured: +;; +;; M-x customize-group RET git-commit RET + +;;; Code: + +(require 'magit-git) +(require 'magit-mode) +(require 'magit-process) + +(require 'log-edit) +(require 'ring) +(require 'server) +(require 'transient) +(require 'with-editor) + +(defvar diff-default-read-only) +(defvar flyspell-generic-check-word-predicate) +(defvar font-lock-beg) +(defvar font-lock-end) +(defvar recentf-exclude) + +(defvar git-commit-need-summary-line) + +(define-obsolete-variable-alias + 'git-commit-known-pseudo-headers + 'git-commit-trailers + "git-commit 4.0.0") + +;;; Options +;;;; Variables + +(defgroup git-commit nil + "Edit Git commit messages." + :prefix "git-commit-" + :link '(info-link "(magit)Editing Commit Messages") + :group 'tools) + +(define-minor-mode global-git-commit-mode + "Edit Git commit messages. + +This global mode arranges for `git-commit-setup' to be called +when a Git commit message file is opened. That usually happens +when Git uses the Emacsclient as $GIT_EDITOR to have the user +provide such a commit message. + +Loading the library `git-commit' by default enables this mode, +but the library is not automatically loaded because doing that +would pull in many dependencies and increase startup time too +much. You can either rely on `magit' loading this library or +you can load it explicitly. Autoloading is not an alternative +because in this case autoloading would immediately trigger +full loading." + :group 'git-commit + :type 'boolean + :global t + :init-value t + :initialize + (lambda (symbol exp) + (custom-initialize-default symbol exp) + (when global-git-commit-mode + (add-hook 'find-file-hook #'git-commit-setup-check-buffer) + (remove-hook 'after-change-major-mode-hook + #'git-commit-setup-font-lock-in-buffer))) + (cond + (global-git-commit-mode + (add-hook 'find-file-hook #'git-commit-setup-check-buffer) + (add-hook 'after-change-major-mode-hook + #'git-commit-setup-font-lock-in-buffer)) + (t + (remove-hook 'find-file-hook #'git-commit-setup-check-buffer) + (remove-hook 'after-change-major-mode-hook + #'git-commit-setup-font-lock-in-buffer)))) + +(defcustom git-commit-major-mode #'text-mode + "Major mode used to edit Git commit messages. + +The major mode configured here is turned on by the minor mode +`git-commit-mode'." + :group 'git-commit + :type '(radio (function-item text-mode) + (function-item markdown-mode) + (function-item org-mode) + (function-item fundamental-mode) + (function-item log-edit-mode) + (function-item git-commit-elisp-text-mode) + (function :tag "Another mode") + (const :tag "No major mode"))) +;;;###autoload(put 'git-commit-major-mode 'safe-local-variable +;;;###autoload (lambda (val) +;;;###autoload (memq val '(text-mode +;;;###autoload markdown-mode +;;;###autoload org-mode +;;;###autoload fundamental-mode +;;;###autoload log-edit-mode +;;;###autoload git-commit-elisp-text-mode)))) + +(defvaralias 'git-commit-mode-hook 'git-commit-setup-hook + "This variable is an alias for `git-commit-setup-hook' (which see). +Also note that `git-commit-mode' (which see) is not a major-mode.") + +(defcustom git-commit-setup-hook + (list #'git-commit-ensure-comment-gap + #'git-commit-save-message + #'git-commit-setup-changelog-support + #'git-commit-turn-on-auto-fill + #'git-commit-propertize-diff + #'bug-reference-mode) + "Hook run at the end of `git-commit-setup'." + :group 'git-commit + :type 'hook + :get #'magit-hook-custom-get + :options '(git-commit-ensure-comment-gap + git-commit-save-message + git-commit-setup-changelog-support + magit-generate-changelog + git-commit-turn-on-auto-fill + git-commit-turn-on-orglink + git-commit-turn-on-flyspell + git-commit-propertize-diff + bug-reference-mode)) + +(defcustom git-commit-post-finish-hook nil + "Hook run after the user finished writing a commit message. + +\\\ +This hook is only run after pressing \\[with-editor-finish] in a buffer used +to edit a commit message. If a commit is created without the +user typing a message into a buffer, then this hook is not run. + +This hook is not run until the new commit has been created. If +that takes Git longer than `git-commit-post-finish-hook-timeout' +seconds, then this hook isn't run at all. For certain commands +such as `magit-rebase-continue' this hook is never run because +doing so would lead to a race condition. + +Also see `magit-post-commit-hook'." + :group 'git-commit + :type 'hook + :get #'magit-hook-custom-get) + +(defcustom git-commit-post-finish-hook-timeout 1 + "Time in seconds to wait for git to create a commit. + +The hook `git-commit-post-finish-hook' (which see) is run only +after git is done creating a commit. If it takes longer than +`git-commit-post-finish-hook-timeout' seconds to create the +commit, then the hook is not run at all." + :group 'git-commit + :safe 'numberp + :type 'number) + +(defcustom git-commit-finish-query-functions + (list #'git-commit-check-style-conventions) + "List of functions called to query before performing commit. + +The commit message buffer is current while the functions are +called. If any of them returns nil, then the commit is not +performed and the buffer is not killed. The user should then +fix the issue and try again. + +The functions are called with one argument. If it is non-nil, +then that indicates that the user used a prefix argument to +force finishing the session despite issues. Functions should +usually honor this wish and return non-nil." + :options '(git-commit-check-style-conventions) + :type 'hook + :group 'git-commit) + +(defcustom git-commit-style-convention-checks '(non-empty-second-line) + "List of checks performed by `git-commit-check-style-conventions'. + +Valid members are `non-empty-second-line' and `overlong-summary-line'. +That function is a member of `git-commit-finish-query-functions'." + :options '(non-empty-second-line overlong-summary-line) + :type '(list :convert-widget custom-hook-convert-widget) + :group 'git-commit) + +(defcustom git-commit-summary-max-length 68 + "Column beyond which characters in the summary lines are highlighted. + +The highlighting indicates that the summary is getting too long +by some standards. It does in no way imply that going over the +limit a few characters or in some cases even many characters is +anything that deserves shaming. It's just a friendly reminder +that if you can make the summary shorter, then you might want +to consider doing so." + :group 'git-commit + :safe 'numberp + :type 'number) + +(defcustom git-commit-trailers + '("Acked-by" + "Modified-by" + "Reviewed-by" + "Signed-off-by" + "Tested-by" + "Cc" + "Reported-by" + "Suggested-by" + "Co-authored-by" + "Co-developed-by") + "A list of Git trailers to be highlighted. + +See also manpage git-interpret-trailer(1). This package does +not use that Git command, but the initial description still +serves as a good introduction." + :group 'git-commit + :safe (##and (listp %) (seq-every-p #'stringp %)) + :type '(repeat string)) + +(defcustom git-commit-use-local-message-ring nil + "Whether to use a local message ring instead of the global one. + +This can be set globally, in which case every repository gets its +own commit message ring, or locally for a single repository." + :group 'git-commit + :safe 'booleanp + :type 'boolean) + +(defcustom git-commit-cd-to-toplevel nil + "Whether to set `default-directory' to the worktree in message buffer. + +Editing a commit message is done by visiting a file located in the git +directory, usually \"COMMIT_EDITMSG\". As is done when visiting any +file, the local value of `default-directory' is set to the directory +that contains the file. + +If this option is non-nil, then the local `default-directory' is changed +to the working tree from which the commit command was invoked. You may +wish to do that, to make it easier to open a file that is located in the +working tree, directly from the commit message buffer. + +If the git variable `safe.bareRepository' is set to \"explicit\", then +you have to enable this, to be able to commit at all. See issue #5100. + +This option only has an effect if the commit was initiated from Magit." + :group 'git-commit + :type 'boolean) + +;;;; Faces + +(defgroup git-commit-faces nil + "Faces used for highlighting Git commit messages." + :prefix "git-commit-" + :group 'git-commit + :group 'faces) + +(defface git-commit-summary + '((t :inherit font-lock-type-face)) + "Face used for the summary in commit messages." + :group 'git-commit-faces) + +(defface git-commit-overlong-summary + '((t :inherit font-lock-warning-face)) + "Face used for the tail of overlong commit message summaries." + :group 'git-commit-faces) + +(defface git-commit-nonempty-second-line + '((t :inherit font-lock-warning-face)) + "Face used for non-whitespace on the second line of commit messages." + :group 'git-commit-faces) + +(defface git-commit-keyword + '((t :inherit font-lock-string-face)) + "Face used for keywords in commit messages. +In this context a \"keyword\" is text surrounded by brackets." + :group 'git-commit-faces) + +(defface git-commit-trailer-token + '((t :inherit font-lock-keyword-face)) + "Face used for Git trailer tokens in commit messages." + :group 'git-commit-faces) + +(defface git-commit-trailer-value + '((t :inherit font-lock-string-face)) + "Face used for Git trailer values in commit messages." + :group 'git-commit-faces) + +(defface git-commit-comment-branch-local + '((t :inherit magit-branch-local)) + "Face used for names of local branches in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-branch-remote + '((t :inherit magit-branch-remote)) + "Face used for names of remote branches in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-detached + '((t :inherit git-commit-comment-branch-local)) + "Face used for detached `HEAD' in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-heading + '((t :inherit git-commit-trailer-token)) + "Face used for headings in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-file + '((t :inherit git-commit-trailer-value)) + "Face used for file names in commit message comments." + :group 'git-commit-faces) + +(defface git-commit-comment-action + '((t :inherit bold)) + "Face used for actions in commit message comments." + :group 'git-commit-faces) + +;;; Keymap + +(defvar-keymap git-commit-redundant-bindings + :doc "Bindings made redundant by `git-commit-insert-trailer'. +This keymap is used as the parent of `git-commit-mode-map', +to avoid upsetting muscle-memory. If you would rather avoid +the redundant bindings, then set this to nil, before loading +`git-commit'." + "C-c C-a" #'git-commit-ack + "C-c M-i" #'git-commit-suggested + "C-c C-m" #'git-commit-modified + "C-c C-o" #'git-commit-cc + "C-c C-p" #'git-commit-reported + "C-c C-r" #'git-commit-review + "C-c C-s" #'git-commit-signoff + "C-c C-t" #'git-commit-test) + +(defvar-keymap git-commit-mode-map + :doc "Keymap used by `git-commit-mode'." + :parent git-commit-redundant-bindings + "M-p" #'git-commit-prev-message + "M-n" #'git-commit-next-message + "C-c M-p" #'git-commit-search-message-backward + "C-c M-n" #'git-commit-search-message-forward + "C-c C-i" #'git-commit-insert-trailer + "C-c M-s" #'git-commit-save-message + "C-c C-d" 'magit-diff-while-committing + "C-c C-w" 'magit-pop-revision-stack) + +;;; Menu + +(require 'easymenu) +(easy-menu-define git-commit-mode-menu git-commit-mode-map + "Git Commit Mode Menu." + '("Commit" + ["Previous" git-commit-prev-message t] + ["Next" git-commit-next-message t] + "-" + ["Ack" git-commit-ack t + :help "Insert an 'Acked-by' trailer"] + ["Modified-by" git-commit-modified t + :help "Insert a 'Modified-by' trailer"] + ["Reviewed-by" git-commit-review t + :help "Insert a 'Reviewed-by' trailer"] + ["Sign-Off" git-commit-signoff t + :help "Insert a 'Signed-off-by' trailer"] + ["Tested-by" git-commit-test t + :help "Insert a 'Tested-by' trailer"] + "-" + ["CC" git-commit-cc t + :help "Insert a 'Cc' trailer"] + ["Reported" git-commit-reported t + :help "Insert a 'Reported-by' trailer"] + ["Suggested" git-commit-suggested t + :help "Insert a 'Suggested-by' trailer"] + ["Co-authored-by" git-commit-co-authored t + :help "Insert a 'Co-authored-by' trailer"] + ["Co-developed-by" git-commit-co-developed t + :help "Insert a 'Co-developed-by' trailer"] + "-" + ["Save" git-commit-save-message t] + ["Cancel" with-editor-cancel t] + ["Commit" with-editor-finish t])) + +;;; Hooks + +(defconst git-commit-filename-regexp "/\\(\ +\\(\\(COMMIT\\|NOTES\\|PULLREQ\\|MERGEREQ\\|TAG\\)_EDIT\\|MERGE_\\|\\)MSG\ +\\|\\(BRANCH\\|EDIT\\)_DESCRIPTION\\)\\'") + +(with-eval-after-load 'recentf + (add-to-list 'recentf-exclude git-commit-filename-regexp)) + +(add-to-list 'with-editor-file-name-history-exclude git-commit-filename-regexp) + +(defun git-commit-setup-font-lock-in-buffer () + (when (and buffer-file-name + (string-match-p git-commit-filename-regexp buffer-file-name)) + (git-commit-setup-font-lock))) + +(defun git-commit-setup-check-buffer () + (when (and buffer-file-name + (string-match-p git-commit-filename-regexp buffer-file-name)) + (git-commit-setup))) + +(defvar git-commit-mode) + +(defun git-commit-file-not-found () + ;; cygwin git will pass a cygwin path (/cygdrive/c/foo/.git/...), + ;; try to handle this in window-nt Emacs. + (when-let* + ((file (and (or (string-match-p git-commit-filename-regexp + buffer-file-name) + (and (boundp 'git-rebase-filename-regexp) + (string-match-p git-rebase-filename-regexp + buffer-file-name))) + (not (file-accessible-directory-p + (file-name-directory buffer-file-name))) + (magit-expand-git-file-name (substring buffer-file-name 2)))) + ((file-accessible-directory-p (file-name-directory file))) + (inhibit-read-only t)) + (insert-file-contents file t) + t)) + +(when (eq system-type 'windows-nt) + (add-hook 'find-file-not-found-functions #'git-commit-file-not-found)) + +(defconst git-commit-default-usage-message "\ +Type \\[with-editor-finish] to finish, \ +\\[with-editor-cancel] to cancel, and \ +\\[git-commit-prev-message] and \\[git-commit-next-message] \ +to recover older messages") + +(defvar git-commit-usage-message git-commit-default-usage-message + "Message displayed when editing a commit message. +When this is nil, then `with-editor-usage-message' is displayed +instead. One of these messages has to be displayed; otherwise +the user gets to see the message displayed by `server-execute'. +That message is misleading and because we cannot prevent it from +being displayed, we have to immediately show another message to +prevent the user from seeing it.") + +(defvar git-commit-header-line-format nil + "If non-nil, header line format used by `git-commit-mode'. +Used as the local value of `header-line-format', in buffer using +`git-commit-mode'. If it is a string, then it is passed through +`substitute-command-keys' first. A useful setting may be: + (setq git-commit-header-line-format git-commit-default-usage-message) + (setq git-commit-usage-message nil) ; show a shorter message") + +(defun git-commit-setup () + (let ((gitdir default-directory) + (cd (and git-commit-cd-to-toplevel + (or (car (rassoc default-directory magit--separated-gitdirs)) + (magit-toplevel))))) + ;; Pretend that git-commit-mode is a major-mode, + ;; so that directory-local settings can be used. + (let ((default-directory + (or (and (not (file-exists-p + (expand-file-name ".dir-locals.el" gitdir))) + ;; When $GIT_DIR/.dir-locals.el doesn't exist, + ;; fallback to $GIT_WORK_TREE/.dir-locals.el, + ;; because the maintainer can use the latter + ;; to enforce conventions, while s/he has no + ;; control over the former. + (or cd (magit-toplevel))) + gitdir))) + (let ((buffer-file-name nil) ; trick hack-dir-local-variables + (major-mode 'git-commit-mode)) ; trick dir-locals-collect-variables + (hack-dir-local-variables) + (hack-local-variables-apply))) + (when cd + (setq default-directory cd))) + (when git-commit-major-mode + (let ((auto-mode-alist + ;; `set-auto-mode--apply-alist' removes the remote part from + ;; the file-name before looking it up in `auto-mode-alist'. + ;; For our temporary entry to be found, we have to modify the + ;; file-name the same way. + (list (cons (concat "\\`" + (regexp-quote + (or (file-remote-p buffer-file-name 'localname) + buffer-file-name)) + "\\'") + git-commit-major-mode))) + ;; The major-mode hook might want to consult these minor + ;; modes, while the minor-mode hooks might want to consider + ;; the major mode. + (git-commit-mode t) + (with-editor-mode t)) + (normal-mode t))) + ;; Below we instead explicitly show a message. + (setq with-editor-show-usage nil) + (unless with-editor-mode + ;; Maybe already enabled when using `shell-command' or an Emacs shell. + (with-editor-mode 1)) + (add-hook 'with-editor-finish-query-functions + #'git-commit-finish-query-functions nil t) + (add-hook 'with-editor-pre-finish-hook #'git-commit-save-message nil t) + (add-hook 'with-editor-pre-cancel-hook #'git-commit-save-message nil t) + (when (fboundp 'magit-commit--reset-command) + (add-hook 'with-editor-post-finish-hook #'magit-commit--reset-command) + (add-hook 'with-editor-post-cancel-hook #'magit-commit--reset-command)) + (unless (memq last-command + '(magit-sequencer-continue + magit-sequencer-skip + magit-am-continue + magit-am-skip + magit-rebase-continue + magit-rebase-skip)) + (add-hook 'with-editor-post-finish-hook + (apply-partially #'git-commit-run-post-finish-hook + (magit-rev-parse "HEAD")) + nil t) + (when (fboundp 'magit-wip-maybe-add-commit-hook) + (magit-wip-maybe-add-commit-hook))) + (setq with-editor-cancel-message + #'git-commit-cancel-message) + (git-commit-setup-font-lock) + (git-commit-prepare-message-ring) + (when (boundp 'save-place) + (setq save-place nil)) + (let ((git-commit-mode-hook nil)) + (git-commit-mode 1)) + (with-demoted-errors "Error running git-commit-setup-hook: %S" + (run-hooks 'git-commit-setup-hook)) + (set-buffer-modified-p nil) + (when-let ((format git-commit-header-line-format)) + (setq header-line-format + (if (stringp format) (substitute-command-keys format) format))) + (when git-commit-usage-message + (setq with-editor-usage-message git-commit-usage-message)) + (with-editor-usage-message)) + +(defun git-commit-run-post-finish-hook (previous) + (when git-commit-post-finish-hook + (cl-block nil + (let ((break (time-add (current-time) + (seconds-to-time + git-commit-post-finish-hook-timeout)))) + (while (equal (magit-rev-parse "HEAD") previous) + (if (time-less-p (current-time) break) + (sit-for 0.01) + (message "No commit created after 1 second. Not running %s." + 'git-commit-post-finish-hook) + (cl-return)))) + (run-hooks 'git-commit-post-finish-hook)))) + +(define-minor-mode git-commit-mode + "Auxiliary minor mode used when editing Git commit messages. +This mode is only responsible for setting up some key bindings. +Don't use it directly; instead enable `global-git-commit-mode'. +Variable `git-commit-major-mode' controls which major-mode is +used." + :lighter "") + +(put 'git-commit-mode 'permanent-local t) + +(defun git-commit-ensure-comment-gap () + "Separate initial empty line from initial comment. +If the buffer begins with an empty line followed by a comment, insert +an additional newline in between, so that once the users start typing, +the input isn't tacked to the comment." + (save-excursion + (goto-char (point-min)) + (when (looking-at (format "\\`\n%s" comment-start)) + (open-line 1)))) + +(defun git-commit-setup-changelog-support () + "Treat ChangeLog entries as unindented paragraphs." + (setq-local fill-paragraph-function #'log-edit-fill-entry) + (setq-local fill-indent-according-to-mode t) + (setq-local paragraph-start (concat paragraph-start "\\|\\*\\|("))) + +(defun git-commit-turn-on-auto-fill () + "Unconditionally turn on Auto Fill mode. +Ensure auto filling happens everywhere, except in the summary line." + (auto-fill-mode 1) + (setq-local comment-auto-fill-only-comments nil) + (when git-commit-need-summary-line + (setq-local auto-fill-function #'git-commit-auto-fill-except-summary))) + +(defun git-commit-auto-fill-except-summary () + (unless (eq (line-beginning-position) 1) + (do-auto-fill))) + +(defun git-commit-turn-on-orglink () + "Turn on Orglink mode if it is available. +If `git-commit-major-mode' is `org-mode', then silently forgo +turning on `orglink-mode'." + (when (and (not (derived-mode-p 'org-mode)) + (boundp 'orglink-match-anywhere) + (fboundp 'orglink-mode)) + (setq-local orglink-match-anywhere t) + (orglink-mode 1))) + +(defun git-commit-turn-on-flyspell () + "Unconditionally turn on Flyspell mode. +Also check text that is already in the buffer, while avoiding to check +most text that Git will strip from the final message, such as the last +comment and anything below the cut line (\"--- >8 ---\")." + (require 'flyspell) + (flyspell-mode 1) + (setq flyspell-generic-check-word-predicate + #'git-commit-flyspell-verify) + (let ((end nil) + ;; The "cut line" is defined in "git/wt-status.c". It appears + ;; in the commit message when `commit.verbose' is set to true. + (cut-line-regex (format "^%s -\\{8,\\} >8 -\\{8,\\}$" comment-start)) + (comment-start-regex (format "^\\(%s\\|$\\)" comment-start))) + (save-excursion + (goto-char (or (re-search-forward cut-line-regex nil t) + (point-max))) + (while (and (not (bobp)) (looking-at comment-start-regex)) + (forward-line -1)) + (unless (looking-at comment-start-regex) + (forward-line)) + (setq end (point))) + (flyspell-region (point-min) end))) + +(defun git-commit-flyspell-verify () + (not (= (char-after (line-beginning-position)) + (aref comment-start 0)))) + +(defun git-commit-finish-query-functions (force) + (run-hook-with-args-until-failure + 'git-commit-finish-query-functions force)) + +(defun git-commit-check-style-conventions (force) + "Check for violations of certain basic style conventions. + +For each violation ask the user if she wants to proceed anyway. +Option `git-commit-style-convention-checks' controls which +conventions are checked." + (or force + (save-excursion + (goto-char (point-min)) + (re-search-forward (git-commit-summary-regexp) nil t) + (if (equal (match-string 1) "") + t ; Just try; we don't know whether --allow-empty-message was used. + (and (or (not (memq 'overlong-summary-line + git-commit-style-convention-checks)) + (equal (match-string 2) "") + (y-or-n-p "Summary line is too long. Commit anyway? ")) + (or (not (memq 'non-empty-second-line + git-commit-style-convention-checks)) + (not (match-string 3)) + (y-or-n-p "Second line is not empty. Commit anyway? "))))))) + +(defun git-commit-cancel-message () + (message + (concat "Commit canceled" + (and (memq 'git-commit-save-message with-editor-pre-cancel-hook) + ". Message saved to `log-edit-comment-ring'")))) + +;;; History + +(defun git-commit-prev-message (arg) + "Cycle backward through message history, after saving current message. +With a numeric prefix ARG, go back ARG messages." + (interactive "*p") + (let ((len (ring-length log-edit-comment-ring))) + (if (<= len 0) + (progn (message "Empty comment ring") (ding)) + ;; Unlike `log-edit-previous-comment' we save the current + ;; non-empty and newly written comment, because otherwise + ;; it would be irreversibly lost. + (when-let* ((message (git-commit-buffer-message)) + ((not (ring-member log-edit-comment-ring message)))) + (ring-insert log-edit-comment-ring message) + (cl-incf arg) + (setq len (ring-length log-edit-comment-ring))) + ;; Delete the message but not the instructions at the end. + (save-restriction + (goto-char (point-min)) + (narrow-to-region + (point) + (if (re-search-forward (concat "^" comment-start) nil t) + (max 1 (- (point) 2)) + (point-max))) + (delete-region (point-min) (point))) + (setq log-edit-comment-ring-index (log-edit-new-comment-index arg len)) + (message "Comment %d" (1+ log-edit-comment-ring-index)) + (insert (ring-ref log-edit-comment-ring log-edit-comment-ring-index))))) + +(defun git-commit-next-message (arg) + "Cycle forward through message history, after saving current message. +With a numeric prefix ARG, go forward ARG messages." + (interactive "*p") + (git-commit-prev-message (- arg))) + +(defun git-commit-search-message-backward (string) + "Search backward through message history for a match for STRING. +Save current message first." + (interactive + (list (read-string (format-prompt "Comment substring" + log-edit-last-comment-match) + nil nil log-edit-last-comment-match))) + (cl-letf (((symbol-function #'log-edit-previous-comment) + (symbol-function #'git-commit-prev-message))) + (log-edit-comment-search-backward string))) + +(defun git-commit-search-message-forward (string) + "Search forward through message history for a match for STRING. +Save current message first." + (interactive + (list (read-string (format-prompt "Comment substring" + log-edit-last-comment-match) + nil nil log-edit-last-comment-match))) + (cl-letf (((symbol-function #'log-edit-previous-comment) + (symbol-function #'git-commit-prev-message))) + (log-edit-comment-search-forward string))) + +(defun git-commit-save-message () + "Save current message to `log-edit-comment-ring'." + (interactive) + (if-let ((message (git-commit-buffer-message))) + (progn + (when-let ((index (ring-member log-edit-comment-ring message))) + (ring-remove log-edit-comment-ring index)) + (ring-insert log-edit-comment-ring message) + (when git-commit-use-local-message-ring + (magit-repository-local-set 'log-edit-comment-ring + log-edit-comment-ring)) + (message "Message saved")) + (message "Only whitespace and/or comments; message not saved"))) + +(defun git-commit-prepare-message-ring () + (make-local-variable 'log-edit-comment-ring-index) + (when git-commit-use-local-message-ring + (setq-local log-edit-comment-ring + (magit-repository-local-get + 'log-edit-comment-ring + (make-ring log-edit-maximum-comment-ring-size))))) + +(defun git-commit-buffer-message () + (let ((flush (concat "^" comment-start)) + (str (buffer-substring-no-properties (point-min) (point-max)))) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (when (re-search-forward (concat flush " -+ >8 -+$") nil t) + (delete-region (line-beginning-position) (point-max))) + (goto-char (point-min)) + (flush-lines flush) + (goto-char (point-max)) + (unless (eq (char-before) ?\n) + (insert ?\n)) + (setq str (buffer-string))) + (and (not (string-match "\\`[ \t\n\r]*\\'" str)) + (progn + (when (string-match "\\`\n\\{2,\\}" str) + (setq str (replace-match "\n" t t str))) + (when (string-match "\n\\{2,\\}\\'" str) + (setq str (replace-match "\n" t t str))) + str)))) + +;;; Trailers + +(transient-define-prefix git-commit-insert-trailer () + "Insert a commit message trailer. + +See also manpage git-interpret-trailer(1). This command does +not use that Git command, but the initial description still +serves as a good introduction." + [[:description (##cond (prefix-arg + "Insert ... by someone ") + ("Insert ... by yourself")) + ("a" "Ack" git-commit-ack) + ("m" "Modified" git-commit-modified) + ("r" "Reviewed" git-commit-review) + ("s" "Signed-off" git-commit-signoff) + ("t" "Tested" git-commit-test)] + ["Insert ... by someone" + ("C-c" "Cc" git-commit-cc) + ("C-r" "Reported" git-commit-reported) + ("C-i" "Suggested" git-commit-suggested) + ("C-a" "Co-authored" git-commit-co-authored) + ("C-d" "Co-developed" git-commit-co-developed)]]) + +(defun git-commit-ack (name mail) + "Insert a trailer acknowledging that you have looked at the commit." + (interactive (git-commit-get-ident "Acked-by")) + (git-commit--insert-ident-trailer "Acked-by" name mail)) + +(defun git-commit-modified (name mail) + "Insert a trailer to signal that you have modified the commit." + (interactive (git-commit-get-ident "Modified-by")) + (git-commit--insert-ident-trailer "Modified-by" name mail)) + +(defun git-commit-review (name mail) + "Insert a trailer acknowledging that you have reviewed the commit. +With a prefix argument, prompt for another person who performed a +review." + (interactive (git-commit-get-ident "Reviewed-by")) + (git-commit--insert-ident-trailer "Reviewed-by" name mail)) + +(defun git-commit-signoff (name mail) + "Insert a trailer to sign off the commit. +With a prefix argument, prompt for another person who signed off." + (interactive (git-commit-get-ident "Signed-off-by")) + (git-commit--insert-ident-trailer "Signed-off-by" name mail)) + +(defun git-commit-test (name mail) + "Insert a trailer acknowledging that you have tested the commit. +With a prefix argument, prompt for another person who tested." + (interactive (git-commit-get-ident "Tested-by")) + (git-commit--insert-ident-trailer "Tested-by" name mail)) + +(defun git-commit-cc (name mail) + "Insert a trailer mentioning someone who might be interested." + (interactive (git-commit-read-ident "Cc")) + (git-commit--insert-ident-trailer "Cc" name mail)) + +(defun git-commit-reported (name mail) + "Insert a trailer mentioning the person who reported the issue." + (interactive (git-commit-read-ident "Reported-by")) + (git-commit--insert-ident-trailer "Reported-by" name mail)) + +(defun git-commit-suggested (name mail) + "Insert a trailer mentioning the person who suggested the change." + (interactive (git-commit-read-ident "Suggested-by")) + (git-commit--insert-ident-trailer "Suggested-by" name mail)) + +(defun git-commit-co-authored (name mail) + "Insert a trailer mentioning the person who co-authored the commit." + (interactive (git-commit-read-ident "Co-authored-by")) + (git-commit--insert-ident-trailer "Co-authored-by" name mail)) + +(defun git-commit-co-developed (name mail) + "Insert a trailer mentioning the person who co-developed the commit." + (interactive (git-commit-read-ident "Co-developed-by")) + (git-commit--insert-ident-trailer "Co-developed-by" name mail)) + +(defun git-commit-get-ident (&optional prompt) + "Return name and email of the user or read another name and email. +If PROMPT and `current-prefix-arg' are both non-nil, read name +and email using `git-commit-read-ident' (which see), otherwise +return name and email of the current user (you)." + (if (and prompt current-prefix-arg) + (git-commit-read-ident prompt) + (list (or (getenv "GIT_AUTHOR_NAME") + (getenv "GIT_COMMITTER_NAME") + (with-demoted-errors "Error running 'git config user.name': %S" + (magit-get "user.name")) + user-full-name + (read-string "Name: ")) + (or (getenv "GIT_AUTHOR_EMAIL") + (getenv "GIT_COMMITTER_EMAIL") + (getenv "EMAIL") + (with-demoted-errors "Error running 'git config user.email': %S" + (magit-get "user.email")) + (read-string "Email: "))))) + +(defalias 'git-commit-self-ident #'git-commit-get-ident) + +(defvar git-commit-read-ident-history nil) + +(defun git-commit-read-ident (prompt) + "Read a name and email, prompting with PROMPT, and return them. +Read them using a single prompt, offering past commit authors as +completion candidates. The input must have the form \"NAME \"." + (let ((str (magit-completing-read + prompt + (sort (delete-dups + (magit-git-lines "log" "-n9999" "--format=%aN <%ae>")) + #'string<) + nil nil nil 'git-commit-read-ident-history))) + (save-match-data + (if (string-match "\\`\\([^<]+\\) *<\\([^>]+\\)>\\'" str) + (list (save-match-data (string-trim (match-string 1 str))) + (string-trim (match-string 2 str))) + (user-error "Invalid input"))))) + +(defun git-commit--insert-ident-trailer (trailer name email) + (git-commit--insert-trailer trailer (format "%s <%s>" name email))) + +(defun git-commit--insert-trailer (trailer value) + (save-excursion + (let ((string (format "%s: %s" trailer value)) + (leading-comment-end nil)) + ;; Make sure we skip forward past any leading comments. + (goto-char (point-min)) + (while (looking-at comment-start) + (forward-line)) + (setq leading-comment-end (point)) + (goto-char (point-max)) + (cond + ;; Look backwards for existing trailers. + ((re-search-backward (git-commit--trailer-regexp) nil t) + (end-of-line) + (insert ?\n string) + (unless (= (char-after) ?\n) + (insert ?\n))) + ;; Or place the new trailer right before the first non-leading + ;; comments. + (t + (while (re-search-backward (concat "^" comment-start) + leading-comment-end t)) + (unless (looking-back "\n\n" nil) + (insert ?\n)) + (insert string ?\n)))) + (unless (or (eobp) (= (char-after) ?\n)) + (insert ?\n)))) + +;;; Font-Lock + +(defvar-local git-commit-need-summary-line t + "Whether the text should have a heading that is separated from the body. + +For commit messages that is a convention that should not +be violated. For notes it is up to the user. If you do +not want to insist on an empty second line here, then use +something like: + + (add-hook \\='git-commit-setup-hook + (lambda () + (when (equal (file-name-nondirectory (buffer-file-name)) + \"NOTES_EDITMSG\") + (setq git-commit-need-summary-line nil))))") + +(defun git-commit--trailer-regexp () + (format + "^\\(?:\\(%s:\\)\\( .*\\)\\|\\([-a-zA-Z]+\\): \\([^<\n]+? <[^>\n]+>\\)\\)" + (regexp-opt git-commit-trailers))) + +(defun git-commit-summary-regexp () + (if git-commit-need-summary-line + (concat + ;; Leading empty lines and comments + (format "\\`\\(?:^\\(?:\\s-*\\|%s.*\\)\n\\)*" comment-start) + ;; Summary line + (format "\\(.\\{0,%d\\}\\)\\(.*\\)" git-commit-summary-max-length) + ;; Non-empty non-comment second line + (format "\\(?:\n%s\\|\n\\(.+\\)\\)?" comment-start)) + "\\(EASTER\\) \\(EGG\\)")) + +(defun git-commit-extend-region-summary-line () + "Identify the multiline summary-regexp construct. +Added to `font-lock-extend-region-functions'." + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (looking-at (git-commit-summary-regexp)) + (let ((summary-beg (match-beginning 0)) + (summary-end (match-end 0))) + (when (or (< summary-beg font-lock-beg summary-end) + (< summary-beg font-lock-end summary-end)) + (setq font-lock-beg (min font-lock-beg summary-beg)) + (setq font-lock-end (max font-lock-end summary-end)))))))) + +(defvar-local git-commit--branch-name-regexp nil) + +(defconst git-commit-comment-headings + '("Changes to be committed:" + "Untracked files:" + "Changed but not updated:" + "Changes not staged for commit:" + "Unmerged paths:" + "Author:" + "Date:") + "Also fontified outside of comments in `git-commit-font-lock-keywords-2'.") + +(defconst git-commit-font-lock-keywords-1 + '(;; Trailers + (eval . `(,(git-commit--trailer-regexp) + (1 'git-commit-trailer-token nil t) + (2 'git-commit-trailer-value nil t) + (3 'git-commit-trailer-token nil t) + (4 'git-commit-trailer-value nil t))) + ;; Summary + (eval . `(,(git-commit-summary-regexp) + (1 'git-commit-summary))) + ;; - Keyword [aka "text in brackets"] (overrides summary) + ("\\[[^][]+?\\]" + (0 'git-commit-keyword t)) + ;; - Non-empty second line (overrides summary and note) + (eval . `(,(git-commit-summary-regexp) + (2 'git-commit-overlong-summary t t) + (3 'git-commit-nonempty-second-line t t))))) + +(defconst git-commit-font-lock-keywords-2 + `(,@git-commit-font-lock-keywords-1 + ;; Comments + (eval . `(,(format "^%s.*" comment-start) + (0 'font-lock-comment-face append))) + (eval . `(,(format "^%s On branch \\(.*\\)" comment-start) + (1 'git-commit-comment-branch-local t))) + (eval . `(,(format "^%s \\(HEAD\\) detached at" comment-start) + (1 'git-commit-comment-detached t))) + (eval . `(,(format "^%s %s" comment-start + (regexp-opt git-commit-comment-headings t)) + (1 'git-commit-comment-heading t))) + (eval . `(,(format "^%s\t\\(?:\\([^:\n]+\\):\\s-+\\)?\\(.*\\)" comment-start) + (1 'git-commit-comment-action t t) + (2 'git-commit-comment-file t))) + ;; "commit HASH" + (eval . '("^commit [[:alnum:]]+$" + (0 'git-commit-trailer-value))) + ;; `git-commit-comment-headings' (but not in commented lines) + (eval . `(,(format "\\(?:^%s[[:blank:]]+.+$\\)" + (regexp-opt git-commit-comment-headings)) + (0 'git-commit-trailer-value))))) + +(defconst git-commit-font-lock-keywords-3 + `(,@git-commit-font-lock-keywords-2 + ;; More comments + (eval + ;; Your branch is ahead of 'master' by 3 commits. + ;; Your branch is behind 'master' by 2 commits, and can be fast-forwarded. + . `(,(format + "^%s Your branch is \\(?:ahead\\|behind\\) of '%s' by \\([0-9]*\\)" + comment-start git-commit--branch-name-regexp) + (1 'git-commit-comment-branch-local t) + (2 'git-commit-comment-branch-remote t) + (3 'bold t))) + (eval + ;; Your branch is up to date with 'master'. + ;; Your branch and 'master' have diverged, + . `(,(format + "^%s Your branch \\(?:is up[- ]to[- ]date with\\|and\\) '%s'" + comment-start git-commit--branch-name-regexp) + (1 'git-commit-comment-branch-local t) + (2 'git-commit-comment-branch-remote t))) + (eval + ;; and have 1 and 2 different commits each, respectively. + . `(,(format + "^%s and have \\([0-9]*\\) and \\([0-9]*\\) commits each" + comment-start) + (1 'bold t) + (2 'bold t))))) + +(defvar git-commit-font-lock-keywords git-commit-font-lock-keywords-3 + "Font-Lock keywords for Git-Commit mode.") + +(defun git-commit-setup-font-lock () + (with-demoted-errors "Error running git-commit-setup-font-lock: %S" + (let ((table (make-syntax-table (syntax-table)))) + (when comment-start + (modify-syntax-entry (string-to-char comment-start) "." table)) + (modify-syntax-entry ?# "." table) + (modify-syntax-entry ?\" "." table) + (modify-syntax-entry ?\' "." table) + (modify-syntax-entry ?` "." table) + (set-syntax-table table)) + (setq-local comment-start (or (magit-get "core.commentchar") "#")) + (setq-local comment-start-skip (format "^%s+[\s\t]*" comment-start)) + (setq-local comment-end "") + (setq-local comment-end-skip "\n") + (setq-local comment-use-syntax nil) + (when (and (derived-mode-p 'markdown-mode) + (fboundp 'markdown-fill-paragraph)) + (setq-local fill-paragraph-function + (lambda (&optional justify) + (and (not (= (char-after (line-beginning-position)) + (aref comment-start 0))) + (markdown-fill-paragraph justify))))) + (setq-local git-commit--branch-name-regexp + ;; When using cygwin git, we may end up in a + ;; non-existing directory, which would cause + ;; any git calls to signal an error. + (if (file-accessible-directory-p default-directory) + ;; Font-Lock wants every submatch to succeed, so + ;; also match the empty string. Avoid listing + ;; remote branches and using `regexp-quote', + ;; because in repositories that have thousands of + ;; branches that would be very slow. See #4353. + (format "\\(\\(?:%s\\)\\|\\)\\([^']+\\)" + (string-join (magit-list-local-branch-names) "\\|")) + "\\([^']*\\)")) + (setq-local font-lock-multiline t) + (add-hook 'font-lock-extend-region-functions + #'git-commit-extend-region-summary-line + t t) + (font-lock-add-keywords nil git-commit-font-lock-keywords))) + +(defun git-commit-propertize-diff () + (require 'diff-mode) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^diff --git" nil t) + (beginning-of-line) + (let ((buffer (current-buffer))) + (insert + (with-temp-buffer + (insert + (with-current-buffer buffer + (prog1 (buffer-substring-no-properties (point) (point-max)) + (delete-region (point) (point-max))))) + (let ((diff-default-read-only nil)) + (diff-mode)) + (let ((font-lock-verbose nil) + (font-lock-support-mode nil)) + (font-lock-ensure)) + (let ((pos (point-min))) + (while-let ((next (next-single-property-change pos 'face))) + (put-text-property pos next 'font-lock-face + (get-text-property pos 'face)) + (setq pos next)) + (put-text-property pos (point-max) 'font-lock-face + (get-text-property pos 'face))) + (buffer-string))))))) + +;;; Elisp Text Mode + +(define-derived-mode git-commit-elisp-text-mode text-mode "ElText" + "Major mode for editing commit messages of elisp projects. +This is intended for use as `git-commit-major-mode' for projects +that expect `symbols' to look like this. I.e., like they look in +Elisp doc-strings, including this one. Unlike in doc-strings, +\"strings\" also look different than the other text." + (setq font-lock-defaults '(git-commit-elisp-text-mode-keywords))) + +(defvar git-commit-elisp-text-mode-keywords + `((,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]") + (1 font-lock-constant-face prepend)) + ("\"[^\"]*\"" (0 font-lock-string-face prepend)))) + +;;; _ + +(define-obsolete-function-alias + 'git-commit-insert-pseudo-header + 'git-commit-insert-trailer + "git-commit 4.0.0") +(define-obsolete-function-alias + 'git-commit-insert-header + 'git-commit--insert-ident-trailer + "git-commit 4.0.0") +(define-obsolete-face-alias + 'git-commit-pseudo-header + 'git-commit-trailer-value + "git-commit 4.0.0") +(define-obsolete-face-alias + 'git-commit-known-pseudo-header + 'git-commit-trailer-token + "git-commit 4.0.0") + +(provide 'git-commit) +;;; git-commit.el ends here blob - /dev/null blob + 486b0422408c2732c8e02d46e9993fd0eac3359c (mode 644) --- /dev/null +++ elpa/magit-4.3.8/git-rebase.el @@ -0,0 +1,934 @@ +;;; git-rebase.el --- Edit Git rebase files -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Phil Jackson +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This package assists the user in editing the list of commits to be +;; rewritten during an interactive rebase. + +;; When the user initiates an interactive rebase, e.g., using "r e" in +;; a Magit buffer or on the command line using "git rebase -i REV", +;; Git invokes the `$GIT_SEQUENCE_EDITOR' (or if that is undefined +;; `$GIT_EDITOR' or even `$EDITOR') letting the user rearrange, drop, +;; reword, edit, and squash commits. + +;; This package provides the major-mode `git-rebase-mode' which makes +;; doing so much more fun, by making the buffer more colorful and +;; providing the following commands: +;; +;; C-c C-c Tell Git to make it happen. +;; C-c C-k Tell Git that you changed your mind, i.e., abort. +;; +;; p Move point to previous line. +;; n Move point to next line. +;; +;; M-p Move the commit at point up. +;; M-n Move the commit at point down. +;; +;; d Drop the commit at point. +;; c Keep the commit at point. +;; r Change the message of the commit at point. +;; e Edit the commit at point. +;; s Squash the commit at point, into the one above. +;; f Like "s" but don't also edit the commit message. +;; b Break for editing at this point in the sequence. +;; x Add a script to be run with the commit at point +;; being checked out. +;; k Un-/comment current line. +;; z Add noop action at point. +;; +;; SPC Show the commit at point in another buffer. +;; RET Show the commit at point in another buffer and +;; select its window. +;; C-/ Undo last change. +;; +;; Commands for --rebase-merges: +;; l Associate label with current HEAD in sequence. +;; MM Merge specified revisions into HEAD. +;; Mt Toggle whether the merge will invoke an editor +;; before committing. +;; t Reset HEAD to the specified label. + +;; You should probably also read the `git-rebase' manpage. + +;;; Code: + +(require 'magit) + +(require 'easymenu) +(require 'server) +(require 'with-editor) + +(defvar recentf-exclude) + +;;; Options +;;;; Variables + +(defgroup git-rebase nil + "Edit Git rebase sequences." + :link '(info-link "(magit)Editing Rebase Sequences") + :group 'tools) + +(defcustom git-rebase-auto-advance t + "Whether to move to next line after changing a line." + :group 'git-rebase + :type 'boolean) + +(defcustom git-rebase-show-instructions t + "Whether to show usage instructions inside the rebase buffer." + :group 'git-rebase + :type 'boolean) + +(defcustom git-rebase-confirm-cancel t + "Whether confirmation is required to cancel." + :group 'git-rebase + :type 'boolean) + +;;;; Faces + +(defgroup git-rebase-faces nil + "Faces used by Git-Rebase mode." + :group 'faces + :group 'git-rebase) + +(defface git-rebase-hash '((t :inherit magit-hash)) + "Face for commit hashes." + :group 'git-rebase-faces) + +(defface git-rebase-label '((t :inherit magit-refname)) + "Face for labels in label, merge, and reset lines." + :group 'git-rebase-faces) + +(defface git-rebase-description '((t nil)) + "Face for commit descriptions." + :group 'git-rebase-faces) + +(defface git-rebase-action + '((t :inherit font-lock-keyword-face)) + "Face for action keywords." + :group 'git-rebase-faces) + +(defface git-rebase-killed-action + '((t :inherit font-lock-comment-face :strike-through t)) + "Face for commented commit action lines." + :group 'git-rebase-faces) + +(defface git-rebase-comment-hash + '((t :inherit git-rebase-hash :weight bold)) + "Face for commit hashes in commit message comments." + :group 'git-rebase-faces) + +(defface git-rebase-comment-heading + '((t :inherit font-lock-keyword-face)) + "Face for headings in rebase message comments." + :group 'git-rebase-faces) + +;;; Keymaps + +(defvar-keymap git-rebase-mode-map + :doc "Keymap for Git-Rebase mode." + :parent special-mode-map + "C-m" #'git-rebase-show-commit + "p" #'git-rebase-backward-line + "n" #'forward-line + "M-p" #'git-rebase-move-line-up + "M-n" #'git-rebase-move-line-down + "c" #'git-rebase-pick + "d" #'git-rebase-drop + "k" #'git-rebase-kill-line + "C-k" #'git-rebase-kill-line + "b" #'git-rebase-break + "e" #'git-rebase-edit + "l" #'git-rebase-label + "M M" #'git-rebase-merge + "M t" #'git-rebase-merge-toggle-editmsg + "m" #'git-rebase-edit + "s" #'git-rebase-squash + "S" #'git-rebase-squish + "f" #'git-rebase-fixup + "F" #'git-rebase-alter + "A" #'git-rebase-alter + "q" #'undefined + "r" #'git-rebase-reword + "w" #'git-rebase-reword + "t" #'git-rebase-reset + "u" #'git-rebase-update-ref + "x" #'git-rebase-exec + "y" #'git-rebase-insert + "z" #'git-rebase-noop + "SPC" #'git-rebase-show-or-scroll-up + "DEL" #'git-rebase-show-or-scroll-down + "C-x C-t" #'git-rebase-move-line-up + "M-" #'git-rebase-move-line-up + "M-" #'git-rebase-move-line-down + " " #'git-rebase-undo) +(put 'git-rebase-alter :advertised-binding (kbd "F")) +(put 'git-rebase-reword :advertised-binding (kbd "r")) +(put 'git-rebase-move-line-up :advertised-binding (kbd "M-p")) +(put 'git-rebase-kill-line :advertised-binding (kbd "k")) + +(easy-menu-define git-rebase-mode-menu git-rebase-mode-map + "Git-Rebase mode menu." + '("Rebase" + ["Pick" git-rebase-pick t] + ["Drop" git-rebase-drop t] + ["Reword" git-rebase-reword t] + ["Edit" git-rebase-edit t] + ["Squash" git-rebase-squash t] + ["Fixup" git-rebase-fixup t] + ["Kill" git-rebase-kill-line t] + ["Noop" git-rebase-noop t] + ["Execute" git-rebase-exec t] + ["Move Down" git-rebase-move-line-down t] + ["Move Up" git-rebase-move-line-up t] + "---" + ["Cancel" with-editor-cancel t] + ["Finish" with-editor-finish t])) + +(defvar git-rebase-command-descriptions + '((with-editor-finish . "tell Git to make it happen") + (with-editor-cancel . "tell Git that you changed your mind, i.e., abort") + (git-rebase-backward-line . "move point to previous line") + (forward-line . "move point to next line") + (git-rebase-move-line-up . "move the commit at point up") + (git-rebase-move-line-down . "move the commit at point down") + (git-rebase-show-or-scroll-up . "show the commit at point in another buffer") + (git-rebase-show-commit + . "show the commit at point in another buffer and select its window") + (undo . "undo last change") + (git-rebase-drop . "drop the commit at point") + (git-rebase-kill-line . "un-/comment current line") + (git-rebase-insert . "insert a line for an arbitrary commit") + (git-rebase-noop . "add noop action at point"))) + +(defvar git-rebase-fixup-descriptions + '((git-rebase-squish + . "fixup -c = use commit, but meld into previous commit,\n#\ + dropping previous commit's message, and open the editor") + (git-rebase-fixup + . "fixup = use commit, but meld into previous commit,\n#\ + dropping 's message") + (git-rebase-alter + . "fixup -C = use commit, but meld into previous commit,\n#\ + dropping previous commit's message"))) + +;;; Commands + +(defun git-rebase-pick () + "Use commit on current line. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "pick")) + +(defun git-rebase-drop () + "Drop commit on current line. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "drop")) + +(defun git-rebase-reword () + "Edit message of commit on current line. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "reword")) + +(defun git-rebase-edit () + "Stop at the commit on the current line. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "edit")) + +(defun git-rebase-squash () + "Fold commit on current line into previous commit, edit combined message. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "squash")) + +(defun git-rebase-squish () + "Fold current into previous commit, discard previous message and edit current. +This is like `git-rebase-squash', except that the other message is kept. +The action indicatore shown in the list commits is \"fixup -c\". If the +region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "fixup -c")) + +(defun git-rebase-fixup () + "Fold commit on current line into previous commit, discard current message. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "fixup")) + +(defun git-rebase-alter () + "Meld current into previous commit, discard previous message and use current. +This is like `git-rebase-fixup', except that the other message is kept. +The action indicatore shown in the list commits is \"fixup -C\". If the +region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action "fixup -C")) + +(defvar-local git-rebase-comment-re nil) + +(defvar git-rebase-short-options + '((?b . "break") + (?d . "drop") + (?e . "edit") + (?f . "fixup") + (?l . "label") + (?m . "merge") + (?p . "pick") + (?r . "reword") + (?s . "squash") + (?t . "reset") + (?u . "update-ref") + (?x . "exec")) + "Alist mapping single key of an action to the full name.") + +(defclass git-rebase-action () + (;; action-type: commit, exec, bare, label, merge + (action-type :initarg :action-type :initform nil) + ;; Examples for each action type: + ;; | action | action options | target | trailer | + ;; |--------+----------------+---------+---------| + ;; | pick | | hash | subject | + ;; | exec | | command | | + ;; | noop | | | | + ;; | reset | | name | subject | + ;; | merge | -C hash | name | subject | + (action :initarg :action :initform nil) + (action-options :initarg :action-options :initform nil) + (target :initarg :target :initform nil) + (trailer :initarg :trailer :initform nil) + (comment-p :initarg :comment-p :initform nil) + (abbrev))) + +(defvar git-rebase-line-regexps + `((commit . ,(concat + (regexp-opt '("d" "drop" + "e" "edit" + "f" "fixup" + "f -C" "fixup -C" + "f -c" "fixup -c" + "p" "pick" + "r" "reword" + "s" "squash") + "\\(?1:") + " \\(?3:[^ \n]+\\) ?\\(?4:.*\\)")) + (exec . "\\(?1:x\\|exec\\) \\(?3:.*\\)") + (bare . ,(concat (regexp-opt '("b" "break" "noop") "\\(?1:") + " *$")) + (label . ,(concat (regexp-opt '("l" "label" + "t" "reset" + "u" "update-ref") + "\\(?1:") + " \\(?3:[^ \n]+\\) ?\\(?4:.*\\)")) + (merge . ,(concat "\\(?1:m\\|merge\\) " + "\\(?:\\(?2:-[cC] [^ \n]+\\) \\)?" + "\\(?3:[^ \n]+\\)" + " ?\\(?4:.*\\)")))) + +;;;###autoload +(defun git-rebase-current-line (&optional batch) + "Parse current line into a `git-rebase-action' instance. +If the current line isn't recognized as a rebase line, an +instance with all nil values is returned, unless optional +BATCH is non-nil, in which case nil is returned. Non-nil +BATCH also ignores commented lines." + (save-excursion + (goto-char (line-beginning-position)) + (if-let ((re-start (if batch + "^" + (format "^\\(?5:%s\\)? *" + (regexp-quote comment-start)))) + (type (seq-some (pcase-lambda (`(,type . ,re)) + (let ((case-fold-search nil)) + (and (looking-at (concat re-start re)) type))) + git-rebase-line-regexps))) + (git-rebase-action + :action-type type + :action (and-let* ((action (match-string-no-properties 1))) + (or (cdr (assoc action git-rebase-short-options)) + action)) + :action-options (match-string-no-properties 2) + :target (match-string-no-properties 3) + :trailer (match-string-no-properties 4) + :comment-p (and (match-string 5) t)) + (and (not batch) + ;; Use empty object rather than nil to ease handling. + (git-rebase-action))))) + +(defun git-rebase-set-action (action) + "Set action of commit line to ACTION. +If the region is active, operate on all lines that it touches. +Otherwise, operate on the current line. As a special case, an +ACTION of nil comments or uncomments the rebase line, regardless +of its action type." + (pcase (git-rebase-region-bounds t) + (`(,beg ,end) + (let ((end-marker (copy-marker end)) + (pt-below-p (and mark-active (< (mark) (point))))) + (set-marker-insertion-type end-marker t) + (goto-char beg) + (while (< (point) end-marker) + (with-slots (action-type target trailer comment-p) + (git-rebase-current-line) + (cond + ((and action (eq action-type 'commit)) + (let ((inhibit-read-only t)) + (magit-delete-line) + (insert (concat action " " target " " trailer "\n")))) + ((and (not action) action-type) + (let ((inhibit-read-only t)) + (if comment-p + (delete-region beg (+ beg 2)) + (insert comment-start " "))) + (forward-line)) + (t + ;; In the case of --rebase-merges, commit lines may have + ;; other lines with other action types, empty lines, and + ;; "Branch" comments interspersed. Move along. + (forward-line))))) + (goto-char + (if git-rebase-auto-advance + end-marker + (if pt-below-p (1- end-marker) beg))) + (goto-char (line-beginning-position)))) + (_ (ding)))) + +(defun git-rebase-line-p (&optional pos) + (save-excursion + (when pos (goto-char pos)) + (and (oref (git-rebase-current-line) action-type) + t))) + +(defun git-rebase-region-bounds (&optional fallback) + "Return region bounds if both ends touch rebase lines. +Each bound is extended to include the entire line touched by the +point or mark. If the region isn't active and FALLBACK is +non-nil, return the beginning and end of the current rebase line, +if any." + (cond + ((use-region-p) + (let ((beg (magit--bol-position (region-beginning))) + (end (magit--eol-position (region-end)))) + (and (git-rebase-line-p beg) + (git-rebase-line-p end) + (list beg (1+ end))))) + ((and fallback (git-rebase-line-p)) + (list (line-beginning-position) + (1+ (line-end-position)))))) + +(defun git-rebase-move-line-down (n) + "Move the current commit (or command) N lines down. +If N is negative, move the commit up instead. With an active +region, move all the lines that the region touches, not just the +current line." + (interactive "p") + (pcase-let* ((`(,beg ,end) + (or (git-rebase-region-bounds) + (list (line-beginning-position) + (1+ (line-end-position))))) + (pt-offset (- (point) beg)) + (mark-offset (and mark-active (- (mark) beg)))) + (save-restriction + (narrow-to-region + (point-min) + (1- + (if git-rebase-show-instructions + (save-excursion + (goto-char (point-min)) + (while (or (git-rebase-line-p) + ;; The output for --rebase-merges has empty + ;; lines and "Branch" comments interspersed. + (looking-at-p "^$") + (looking-at-p (concat git-rebase-comment-re + " Branch"))) + (forward-line)) + (line-beginning-position)) + (point-max)))) + (if (or (and (< n 0) (= beg (point-min))) + (and (> n 0) (= end (point-max))) + (> end (point-max))) + (ding) + (goto-char (if (< n 0) beg end)) + (forward-line n) + (atomic-change-group + (let ((inhibit-read-only t)) + (insert (delete-and-extract-region beg end))) + (let ((new-beg (- (point) (- end beg)))) + (when (use-region-p) + (setq deactivate-mark nil) + (set-mark (+ new-beg mark-offset))) + (goto-char (+ new-beg pt-offset)))))))) + +(defun git-rebase-move-line-up (n) + "Move the current commit (or command) N lines up. +If N is negative, move the commit down instead. With an active +region, move all the lines that the region touches, not just the +current line." + (interactive "p") + (git-rebase-move-line-down (- n))) + +(defun git-rebase-highlight-region (start end window rol) + (let ((inhibit-read-only t) + (deactivate-mark nil) + (bounds (git-rebase-region-bounds))) + (mapc #'delete-overlay magit-section-highlight-overlays) + (when bounds + (magit-section-highlight-range (car bounds) (cadr bounds) + 'magit-section-heading-selection)) + (if (and bounds (not magit-section-keep-region-overlay)) + (funcall (default-value 'redisplay-unhighlight-region-function) rol) + (funcall (default-value 'redisplay-highlight-region-function) + start end window rol)))) + +(defun git-rebase-unhighlight-region (rol) + (mapc #'delete-overlay magit-section-highlight-overlays) + (funcall (default-value 'redisplay-unhighlight-region-function) rol)) + +(defun git-rebase-kill-line () + "Comment the current action line. +If the action line is already commented, then uncomment it. +If the region is active, act on all lines touched by the region." + (interactive) + (git-rebase-set-action nil)) + +(defun git-rebase-insert (rev) + "Read an arbitrary commit and insert it below current line." + (interactive (list (magit-read-branch-or-commit "Insert revision"))) + (forward-line) + (if-let ((info (magit-rev-format "%h %s" rev))) + (let ((inhibit-read-only t)) + (insert "pick " info ?\n)) + (user-error "Unknown revision"))) + +(defun git-rebase-set-noncommit-action (action value-fn arg) + (goto-char (line-beginning-position)) + (pcase-let* ((inhibit-read-only t) + (`(,initial ,trailer ,comment-p) + (and (not arg) + (with-slots ((ln-action action) + target trailer comment-p) + (git-rebase-current-line) + (and (equal ln-action action) + (list target trailer comment-p))))) + (value (funcall value-fn initial))) + (pcase (list value initial comment-p) + (`("" nil ,_) + (ding)) + (`("" ,_ ,_) + (magit-delete-line)) + (_ + (if initial + (magit-delete-line) + (forward-line)) + (insert (concat action " " value + (and (equal value initial) + trailer + (concat " " trailer)) + "\n")) + (unless git-rebase-auto-advance + (forward-line -1)))))) + +(defun git-rebase-exec (arg) + "Insert a shell command to be run after the current commit. + +If there already is such a command on the current line, then edit +that instead. With a prefix argument insert a new command even +when there already is one on the current line. With empty input +remove the command on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "exec" + (lambda (initial) (read-shell-command "Execute: " initial)) + arg)) + +(defun git-rebase-label (arg) + "Add a label after the current commit. +If there already is a label on the current line, then edit that +instead. With a prefix argument, insert a new label even when +there is already a label on the current line. With empty input, +remove the label on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "label" + (lambda (initial) + (read-from-minibuffer + "Label: " initial magit-minibuffer-local-ns-map)) + arg)) + +(defun git-rebase-buffer-labels () + (let (labels) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\(?:l\\|label\\) \\([^ \n]+\\)" nil t) + (push (match-string-no-properties 1) labels))) + (nreverse labels))) + +(defun git-rebase-reset (arg) + "Reset the current HEAD to a label. +If there already is a reset command on the current line, then +edit that instead. With a prefix argument, insert a new reset +line even when point is already on a reset line. With empty +input, remove the reset command on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "reset" + (lambda (initial) + (or (magit-completing-read "Label" (git-rebase-buffer-labels) + nil t initial) + "")) + arg)) + +(defun git-rebase-update-ref (arg) + "Insert an update-ref action after the current line. +If there is already an update-ref action on the current line, +then edit that instead. With a prefix argument, insert a new +action even when there is already one on the current line. With +empty input, remove the action on the current line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "update-ref" + (lambda (initial) + (or (magit-completing-read "Ref" (magit-list-refs) nil nil initial) + "")) + arg)) + +(defun git-rebase-merge (arg) + "Add a merge command after the current commit. +If there is already a merge command on the current line, then +replace that command instead. With a prefix argument, insert a +new merge command even when there is already one on the current +line. With empty input, remove the merge command on the current +line, if any." + (interactive "P") + (git-rebase-set-noncommit-action + "merge" + (lambda (_) + (or (magit-completing-read "Merge" (git-rebase-buffer-labels)) + "")) + arg)) + +(defun git-rebase-merge-toggle-editmsg () + "Toggle whether an editor is invoked when performing the merge at point. +When a merge command uses a lower-case -c, the message for the +specified commit will be opened in an editor before creating the +commit. For an upper-case -C, the message will be used as is." + (interactive) + (with-slots (action-type target action-options trailer) + (git-rebase-current-line) + (if (eq action-type 'merge) + (let ((inhibit-read-only t)) + (magit-delete-line) + (insert + (format "merge %s %s %s\n" + (replace-regexp-in-string + "-[cC]" (##if (equal % "-c") "-C" "-c") + action-options t t) + target + trailer))) + (ding)))) + +(defun git-rebase-set-bare-action (action arg) + (goto-char (line-beginning-position)) + (with-slots ((ln-action action) comment-p) + (git-rebase-current-line) + (let ((same-action-p (equal action ln-action)) + (inhibit-read-only t)) + (when (or arg + (not ln-action) + (not same-action-p) + (and same-action-p comment-p)) + (unless (or arg (not same-action-p)) + (magit-delete-line)) + (insert action ?\n) + (unless git-rebase-auto-advance + (forward-line -1)))))) + +(defun git-rebase-noop (&optional arg) + "Add noop action at point. + +If the current line already contains a noop action, leave it +unchanged. If there is a commented noop action present, remove +the comment. Otherwise add a new noop action. With a prefix +argument insert a new noop action regardless of what is already +present on the current line. + +A noop action can be used to make git perform a rebase even if +no commits are selected. Without the noop action present, git +would see an empty file and therefore do nothing." + (interactive "P") + (git-rebase-set-bare-action "noop" arg)) + +(defun git-rebase-break (&optional arg) + "Add break action at point. + +If there is a commented break action present, remove the comment. +If the current line already contains a break action, add another +break action only if a prefix argument is given. + +A break action can be used to interrupt the rebase at the +specified point. It is particularly useful for pausing before +the first commit in the sequence. For other cases, the +equivalent behavior can be achieved with `git-rebase-edit'." + (interactive "P") + (git-rebase-set-bare-action "break" arg)) + +(defun git-rebase-undo (&optional arg) + "Undo some previous changes. +Like `undo' but works in read-only buffers." + (interactive "P") + (let ((inhibit-read-only t)) + (undo arg))) + +(defun git-rebase--show-commit (&optional scroll) + (let ((magit--disable-save-buffers t)) + (save-excursion + (goto-char (line-beginning-position)) + (if-let ((rev (with-slots (action-type target) + (git-rebase-current-line) + (and (eq action-type 'commit) + target)))) + (pcase scroll + ('up (magit-diff-show-or-scroll-up)) + ('down (magit-diff-show-or-scroll-down)) + (_ (apply #'magit-show-commit rev + (magit-diff-arguments 'magit-revision-mode)))) + (ding))))) + +(defun git-rebase-show-commit () + "Show the commit on the current line if any." + (interactive) + (git-rebase--show-commit)) + +(defun git-rebase-show-or-scroll-up () + "Update the commit buffer for commit on current line. + +Either show the commit at point in the appropriate buffer, or if +that buffer is already being displayed in the current frame and +contains information about that commit, then instead scroll the +buffer up." + (interactive) + (git-rebase--show-commit 'up)) + +(defun git-rebase-show-or-scroll-down () + "Update the commit buffer for commit on current line. + +Either show the commit at point in the appropriate buffer, or if +that buffer is already being displayed in the current frame and +contains information about that commit, then instead scroll the +buffer down." + (interactive) + (git-rebase--show-commit 'down)) + +(defun git-rebase-backward-line (&optional n) + "Move N lines backward (forward if N is negative). +Like `forward-line' but go into the opposite direction." + (interactive "p") + (forward-line (- (or n 1)))) + +;;; Mode + +;;;###autoload +(define-derived-mode git-rebase-mode special-mode "Git Rebase" + "Major mode for editing of a Git rebase file. + +Rebase files are generated when you run \"git rebase -i\" or run +`magit-interactive-rebase'. They describe how Git should perform +the rebase. See the documentation for git-rebase (e.g., by +running \"man git-rebase\" at the command line) for details." + :interactive nil + :group 'git-rebase + (setq comment-start (or (magit-get "core.commentChar") "#")) + (setq git-rebase-comment-re (concat "^" (regexp-quote comment-start))) + (setq font-lock-defaults (list (git-rebase-mode-font-lock-keywords) t t)) + (unless git-rebase-show-instructions + (let ((inhibit-read-only t)) + (flush-lines git-rebase-comment-re))) + (unless with-editor-mode + ;; Maybe already enabled when using `shell-command' or an Emacs shell. + (with-editor-mode 1)) + (when git-rebase-confirm-cancel + (add-hook 'with-editor-cancel-query-functions + #'git-rebase-cancel-confirm nil t)) + (setq-local redisplay-highlight-region-function + #'git-rebase-highlight-region) + (setq-local redisplay-unhighlight-region-function + #'git-rebase-unhighlight-region) + (add-hook 'with-editor-pre-cancel-hook #'git-rebase-autostash-save nil t) + (add-hook 'with-editor-post-cancel-hook #'git-rebase-autostash-apply nil t) + (setq imenu-prev-index-position-function + #'magit-imenu--rebase-prev-index-position-function) + (setq imenu-extract-index-name-function + #'magit-imenu--rebase-extract-index-name-function) + (when (boundp 'save-place) + (setq save-place nil))) + +(defun git-rebase-cancel-confirm (force) + (or (not (buffer-modified-p)) + force + (magit-confirm 'abort-rebase "Abort this rebase" nil 'noabort))) + +(defun git-rebase-autostash-save () + (when-let ((rev (magit-file-line + (expand-file-name "rebase-merge/autostash" (magit-gitdir))))) + (push (cons 'stash rev) with-editor-cancel-alist))) + +(defun git-rebase-autostash-apply () + (when-let ((rev (cdr (assq 'stash with-editor-cancel-alist)))) + (magit-stash-apply rev))) + +(defun git-rebase-match-comment-line (limit) + (re-search-forward (concat git-rebase-comment-re ".*") limit t)) + +(defun git-rebase-mode-font-lock-keywords () + "Font lock keywords for Git-Rebase mode." + `((,(concat "^" (cdr (assq 'commit git-rebase-line-regexps))) + (1 'git-rebase-action) + (3 'git-rebase-hash) + (4 'git-rebase-description)) + (,(concat "^" (cdr (assq 'exec git-rebase-line-regexps))) + (1 'git-rebase-action) + (3 'git-rebase-description)) + (,(concat "^" (cdr (assq 'bare git-rebase-line-regexps))) + (1 'git-rebase-action)) + (,(concat "^" (cdr (assq 'label git-rebase-line-regexps))) + (1 'git-rebase-action) + (3 'git-rebase-label) + (4 'font-lock-comment-face)) + ("^\\(m\\(?:erge\\)?\\) -[Cc] \\([^ \n]+\\) \\([^ \n]+\\)\\( #.*\\)?" + (1 'git-rebase-action) + (2 'git-rebase-hash) + (3 'git-rebase-label) + (4 'font-lock-comment-face)) + ("^\\(m\\(?:erge\\)?\\) \\([^ \n]+\\)" + (1 'git-rebase-action) + (2 'git-rebase-label)) + ("^drop \\(.+\\)" + 1 'git-rebase-killed-action t) + (,(concat git-rebase-comment-re " *" + (cdr (assq 'commit git-rebase-line-regexps))) + 0 'git-rebase-killed-action t) + (git-rebase-match-comment-line 0 'font-lock-comment-face) + ("\\[[^[]*\\]" + 0 'magit-keyword t) + ("\\(?:fixup!\\|squash!\\|amend!\\)" + 0 'magit-keyword-squash t) + (,(format "^%s Rebase \\([^ ]*\\) onto \\([^ ]*\\)" comment-start) + (1 'git-rebase-comment-hash t) + (2 'git-rebase-comment-hash t)) + (,(format "^%s \\(Commands:\\)" comment-start) + (1 'git-rebase-comment-heading t)) + (,(format "^%s Branch \\(.*\\)" comment-start) + (1 'git-rebase-label t)))) + +(defun git-rebase-mode-show-keybindings () + "Modify the \"Commands:\" section of the comment Git generates. +Modify that section to replace Git's one-letter command abbreviation, +with the key bindings used in Magit. By default, these are the same, +except for the \"pick\" command." + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (when (and git-rebase-show-instructions + (re-search-forward + (concat git-rebase-comment-re "\\s-+p, pick") + nil t)) + (goto-char (line-beginning-position)) + (git-rebase--insert-descriptions git-rebase-command-descriptions) + (let ((cmd nil) + (line (concat git-rebase-comment-re "\\(?:\\( \\.? *\\)\\|" + "\\( +\\)\\([^\n,],\\) \\([^\n ]+\\) \\)"))) + (while (re-search-forward line nil t) + (if (match-string 1) + (if (assq cmd git-rebase-fixup-descriptions) + (delete-line) + (replace-match (make-string 10 ?\s) t t nil 1)) + (setq cmd (intern (concat "git-rebase-" (match-string 4)))) + (cond + ((not (fboundp cmd)) + (delete-line)) + ((eq cmd 'git-rebase-fixup) + (delete-line) + (git-rebase--insert-descriptions git-rebase-fixup-descriptions)) + (t + (add-text-properties (line-beginning-position) + (1+ (line-end-position)) + '(font-lock-face font-lock-comment-face)) + (replace-match " " t t nil 2) + (replace-match + (string-pad + (save-match-data + (substitute-command-keys (format "\\[%s]" cmd))) + 8) + t t nil 3)))))))))) + +(defun git-rebase--insert-descriptions (alist) + (pcase-dolist (`(,cmd . ,desc) alist) + (insert (format (propertize "%s %s %s\n" + 'font-lock-face 'font-lock-comment-face) + comment-start + (string-pad + (substitute-command-keys (format "\\[%s]" cmd)) 8) + (replace-regexp-in-string "#" comment-start desc))))) + +(add-hook 'git-rebase-mode-hook #'git-rebase-mode-show-keybindings t) + +(defun git-rebase-mode-disable-before-save-hook () + (setq-local before-save-hook nil)) + +(add-hook 'git-rebase-mode-hook #'git-rebase-mode-disable-before-save-hook) + +;;;###autoload +(defconst git-rebase-filename-regexp "/git-rebase-todo\\'") +;;;###autoload +(add-to-list 'auto-mode-alist + (cons git-rebase-filename-regexp #'git-rebase-mode)) + +(add-to-list 'with-editor-server-window-alist + (cons git-rebase-filename-regexp #'switch-to-buffer)) + +(with-eval-after-load 'recentf + (add-to-list 'recentf-exclude git-rebase-filename-regexp)) + +(add-to-list 'with-editor-file-name-history-exclude git-rebase-filename-regexp) + +;;; Imenu Support + +(defun magit-imenu--rebase-prev-index-position-function () + "Move point to previous commit in git-rebase buffer. +Used as a value for `imenu-prev-index-position-function'." + (catch 'found + (while (not (bobp)) + (git-rebase-backward-line) + (when (git-rebase-line-p) + (throw 'found t))))) + +(defun magit-imenu--rebase-extract-index-name-function () + "Return imenu name for line at point. +Point should be at the beginning of the line. This function +is used as a value for `imenu-extract-index-name-function'." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + +;;; _ +(provide 'git-rebase) +;;; git-rebase.el ends here blob - /dev/null blob + 9a52cc46552793a64b615f6fbac484205e559a0e (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-apply.el @@ -0,0 +1,834 @@ +;;; magit-apply.el --- Apply Git diffs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements commands for applying Git diffs or parts +;; of such a diff. The supported "apply variants" are apply, stage, +;; unstage, discard, and reverse - more than Git itself knows about, +;; at least at the porcelain level. + +;;; Code: + +(require 'magit-core) +(require 'magit-diff) +(require 'magit-wip) + +(require 'transient) ; See #3732. + +;; For `magit-apply' +(declare-function magit-am "magit-sequence" () t) +(declare-function magit-patch-apply "magit-patch" () t) +;; For `magit-discard-files' +(declare-function magit-checkout-stage "magit-merge" (file arg)) +(declare-function magit-checkout-read-stage "magit-merge" (file)) +(defvar auto-revert-verbose) +;; For `magit-stage-untracked' +(declare-function magit-submodule-add-1 "magit-submodule" + (url &optional path name args)) +(declare-function magit-submodule-read-name-for-path "magit-submodule" + (path &optional prefer-short)) +(defvar borg-user-emacs-directory) + +;;; Options + +(defcustom magit-delete-by-moving-to-trash t + "Whether Magit uses the system's trash can. + +You should absolutely not disable this and also remove `discard' +from `magit-no-confirm'. You shouldn't do that even if you have +all of the Magit-Wip modes enabled, because those modes do not +track any files that are not tracked in the proper branch." + :package-version '(magit . "2.1.0") + :group 'magit-essentials + :type 'boolean) + +(defcustom magit-unstage-committed t + "Whether unstaging a committed change reverts it instead. + +A committed change cannot be unstaged, because staging and +unstaging are actions that are concerned with the differences +between the index and the working tree, not with committed +changes. + +If this option is non-nil (the default), then typing \"u\" +\(`magit-unstage') on a committed change, causes it to be +reversed in the index but not the working tree. For more +information see command `magit-reverse-in-index'." + :package-version '(magit . "2.4.1") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-reverse-atomically nil + "Whether to reverse changes atomically. + +If some changes can be reversed while others cannot, then nothing +is reversed if the value of this option is non-nil. But when it +is nil, then the changes that can be reversed are reversed and +for the other changes diff files are created that contain the +rejected reversals." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-post-stage-hook nil + "Hook run after staging changes. +This hook is run by `magit-refresh' if `this-command' +is a member of `magit-post-stage-hook-commands'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +(defcustom magit-post-unstage-hook nil + "Hook run after unstaging changes. +This hook is run by `magit-refresh' if `this-command' +is a member of `magit-post-unstage-hook-commands'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +;;; Commands +;;;; Apply + +(defun magit-apply (&rest args) + "Apply the change at point to the working tree. +With a prefix argument fallback to a 3-way merge. Doing +so causes the change to be applied to the index as well." + (interactive (and current-prefix-arg (list "--3way"))) + (when-let ((s (magit-apply--get-selection))) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(,(or 'unstaged 'staged) ,_) + (user-error "Change is already in the working tree")) + (`(untracked ,(or 'file 'files)) + (call-interactively #'magit-am)) + (`(,_ region) (magit-apply-region s args)) + (`(,_ hunk) (magit-apply-hunk s args)) + (`(,_ hunks) (magit-apply-hunks s args)) + (`(rebase-sequence file) + (call-interactively #'magit-patch-apply)) + (`(,_ file) (magit-apply-diff s args)) + (`(,_ files) (magit-apply-diffs s args))))) + +(defun magit-apply--section-content (section) + (buffer-substring-no-properties (if (magit-hunk-section-p section) + (oref section start) + (oref section content)) + (oref section end))) + +(defun magit-apply-diffs (sections &rest args) + (setq sections (magit-apply--get-diffs sections)) + (magit-apply-patch sections args + (mapconcat (##concat (magit-diff-file-header %) + (magit-apply--section-content %)) + sections ""))) + +(defun magit-apply-diff (section &rest args) + (setq section (car (magit-apply--get-diffs (list section)))) + (magit-apply-patch section args + (concat (magit-diff-file-header section) + (magit-apply--section-content section)))) + +(defun magit-apply--adjust-hunk-new-starts (hunks) + "Adjust new line numbers in headers of HUNKS for partial application. +HUNKS should be a list of ordered, contiguous hunks to be applied +from a file. For example, if there is a sequence of hunks with +the headers + + @@ -2,6 +2,7 @@ + @@ -10,6 +11,7 @@ + @@ -18,6 +20,7 @@ + +and only the second and third are to be applied, they would be +adjusted as \"@@ -10,6 +10,7 @@\" and \"@@ -18,6 +19,7 @@\"." + (let* ((first-hunk (car hunks)) + (offset (if (string-match diff-hunk-header-re-unified first-hunk) + (- (string-to-number (match-string 3 first-hunk)) + (string-to-number (match-string 1 first-hunk))) + (error "Header hunks have to be applied individually")))) + (if (= offset 0) + hunks + (mapcar (lambda (hunk) + (if (string-match diff-hunk-header-re-unified hunk) + (replace-match (number-to-string + (- (string-to-number (match-string 3 hunk)) + offset)) + t t hunk 3) + (error "Hunk does not have expected header"))) + hunks)))) + +(defun magit-apply--adjust-hunk-new-start (hunk) + (car (magit-apply--adjust-hunk-new-starts (list hunk)))) + +(defun magit-apply-hunks (hunks &rest args) + (let ((file (oref (car hunks) parent))) + (when (magit-diff--combined-p file) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (magit-apply-patch + file args + (concat (oref file header) + (string-join (magit-apply--adjust-hunk-new-starts + (mapcar #'magit-apply--section-content hunks))))))) + +(defun magit-apply-hunk (hunk &rest args) + (let ((file (oref hunk parent))) + (when (magit-diff--combined-p file) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (let* ((header (car (oref hunk value))) + (header (and (symbolp header) header)) + (content (magit-apply--section-content hunk))) + (magit-apply-patch + file args + (concat (magit-diff-file-header hunk (not (eq header 'rename))) + (if header + content + (magit-apply--adjust-hunk-new-start content))))))) + +(defun magit-apply-region (hunk &rest args) + (let ((file (oref hunk parent))) + (when (magit-diff--combined-p file) + (user-error "Cannot un-/stage resolution hunks. Stage the whole file")) + (magit-apply-patch + file args + (concat (magit-diff-file-header hunk) + (magit-apply--adjust-hunk-new-start + (magit-diff-hunk-region-patch hunk args)))))) + +(defun magit-apply-patch (section:s args patch) + (let* ((files (if (atom section:s) + (list (oref section:s value)) + (mapcar (##oref % value) section:s))) + (command (symbol-name this-command)) + (command (if (and command (string-match "^magit-\\([^-]+\\)" command)) + (match-string 1 command) + "apply")) + (context (magit-diff-get-context)) + (ignore-context (magit-diff-ignore-any-space-p))) + (unless (magit-diff-context-p) + (user-error "Not enough context to apply patch. Increase the context")) + (when (and magit-wip-before-change-mode (not magit-inhibit-refresh)) + (magit-wip-commit-before-change files (concat " before " command))) + (with-temp-buffer + (insert patch) + (let ((magit-inhibit-refresh t)) + (magit-run-git-with-input + "apply" args "-p0" + (if ignore-context "-C0" (format "-C%s" context)) + "--ignore-space-change" "-"))) + (unless magit-inhibit-refresh + (when magit-wip-after-apply-mode + (magit-wip-commit-after-apply files (concat " after " command))) + (magit-refresh)))) + +(defun magit-apply--get-selection () + (or (magit-region-sections '(hunk file module) t) + (let ((section (magit-current-section))) + (pcase (oref section type) + ((or 'hunk 'file 'module) section) + ((or 'staged 'unstaged + 'stashed-index 'stashed-worktree 'stashed-untracked) + (oref section children)) + ('untracked t) + (_ (user-error "Cannot apply this, it's not a change")))))) + +(defun magit-apply--get-diffs (sections) + (magit-section-case + ([file diffstat] + (mapcar (lambda (section) + (or (magit-get-section + (append `((file . ,(oref section value))) + (magit-section-ident magit-root-section))) + (error "Cannot get required diff headers"))) + sections)) + (t sections))) + +(defun magit-apply--ignore-whitespace-p (selection type scope) + "Return t if it is necessary and possible to ignore whitespace. +It is necessary to do so when the diff ignores whitespace changes +and whole files are being applied. It is possible when no binary +files are involved. If it is both necessary and impossible, then +return nil, possibly causing whitespace changes to be applied." + (and (memq type '(unstaged staged)) + (memq scope '(file files list)) + (cl-find-if (lambda (arg) + (member arg '("--ignore-space-at-eol" + "--ignore-space-change" + "--ignore-all-space" + "--ignore-blank-lines"))) + magit-buffer-diff-args) + (not (cl-find-if (##oref % binary) + (ensure-list selection))))) + +;;;; Stage + +(defun magit-stage (&optional intent) + "Add the change at point to the staging area. +With a prefix argument, INTENT, and an untracked file (or files) +at point, stage the file but not its content." + (interactive "P") + (if-let ((s (and (derived-mode-p 'magit-mode) + (magit-apply--get-selection))) + (type (magit-diff-type)) + (scope (magit-diff-scope))) + (pcase (list type scope + (magit-apply--ignore-whitespace-p s type scope)) + (`(untracked ,_ ,_) (magit-stage-untracked intent)) + (`(unstaged region ,_) (magit-apply-region s "--cached")) + (`(unstaged hunk ,_) (magit-apply-hunk s "--cached")) + (`(unstaged hunks ,_) (magit-apply-hunks s "--cached")) + ('(unstaged file t) (magit-apply-diff s "--cached")) + ('(unstaged files t) (magit-apply-diffs s "--cached")) + ('(unstaged list t) (magit-apply-diffs s "--cached")) + ('(unstaged file nil) (magit-stage-1 "-u" (list (oref s value)))) + ('(unstaged files nil) (magit-stage-1 "-u" (magit-region-values nil t))) + ('(unstaged list nil) (magit-stage-modified)) + (`(staged ,_ ,_) (user-error "Already staged")) + (`(committed ,_ ,_) (user-error "Cannot stage committed changes")) + (`(undefined ,_ ,_) (user-error "Cannot stage this change"))) + (call-interactively #'magit-stage-files))) + +;;;###autoload +(defun magit-stage-files (files &optional force) + "Read one or more files and stage all changes in those files. +With prefix argument FORCE, offer ignored files for completion." + (interactive + (let* ((choices (if current-prefix-arg + (magit-ignored-files) + (nconc (magit-unstaged-files) + (magit-untracked-files)))) + (default (or (magit-section-value-if 'file) + (magit-file-relative-name))) + (default (car (member default choices)))) + (list (magit-completing-read-multiple + (if current-prefix-arg "Stage ignored file,s: " "Stage file,s: ") + choices nil t nil nil default) + current-prefix-arg))) + (magit-with-toplevel + (magit-stage-1 (and force "--force") files))) + +;;;###autoload +(defun magit-stage-modified (&optional all) + "Stage all changes to files modified in the worktree. +Stage all new content of tracked files and remove tracked files +that no longer exist in the working tree from the index also. +With a prefix argument also stage previously untracked (but not +ignored) files." + (interactive "P") + (when (magit-anything-staged-p) + (magit-confirm 'stage-all-changes)) + (magit-with-toplevel + (magit-stage-1 (if all "--all" "-u") magit-buffer-diff-files))) + +(defun magit-stage-1 (arg &optional files) + (magit-wip-commit-before-change files " before stage") + (magit-run-git "add" arg (if files (cons "--" files) ".")) + (when magit-auto-revert-mode + (mapc #'magit-turn-on-auto-revert-mode-if-desired files)) + (magit-wip-commit-after-apply files " after stage")) + +(defun magit-stage-untracked (&optional intent) + (let* ((section (magit-current-section)) + (files (pcase (magit-diff-scope) + ('file (list (oref section value))) + ('files (magit-region-values nil t)) + ('list (magit-untracked-files)))) + plain repos) + (dolist (file files) + (if (and (not (file-symlink-p file)) + (magit-git-repo-p file t)) + (push file repos) + (push file plain))) + (magit-wip-commit-before-change files " before stage") + (when plain + (magit-run-git "add" (and intent "--intent-to-add") + "--" plain) + (when magit-auto-revert-mode + (mapc #'magit-turn-on-auto-revert-mode-if-desired plain))) + (when (and (fboundp 'borg-assimilate) + (fboundp 'borg--maybe-absorb-gitdir) + (fboundp 'borg--sort-submodule-sections)) + (dolist (repo repos) + (save-excursion + (when-let ((section (magit-get-section + `((file . ,repo) (untracked) (status))))) + (goto-char (oref section start)) + (let* ((topdir (magit-toplevel)) + (url (let ((default-directory + (file-name-as-directory (expand-file-name repo)))) + (or (magit-get "remote" (magit-get-some-remote) "url") + (concat (file-name-as-directory ".") repo)))) + (package + (and (equal borg-user-emacs-directory topdir) + (file-name-nondirectory (directory-file-name repo))))) + (if (and package + (y-or-n-p (format "Also assimilate `%s' drone?" package))) + (borg-assimilate package url) + (magit-submodule-add-1 + url repo (magit-submodule-read-name-for-path repo package)) + (when package + (borg--sort-submodule-sections + (expand-file-name ".gitmodules" topdir)) + (let ((default-directory borg-user-emacs-directory)) + (borg--maybe-absorb-gitdir package))))))))) + (magit-wip-commit-after-apply files " after stage"))) + +(defvar magit-post-stage-hook-commands + (list #'magit-stage + #'magit-stage-files + #'magit-stage-modified + 'magit-file-stage)) + +(defun magit-run-post-stage-hook () + (when (memq this-command magit-post-stage-hook-commands) + (magit-run-hook-with-benchmark 'magit-post-stage-hook))) + +;;;; Unstage + +(defun magit-unstage () + "Remove the change at point from the staging area." + (interactive) + (when-let ((s (magit-apply--get-selection)) + (type (magit-diff-type)) + (scope (magit-diff-scope))) + (pcase (list type scope + (magit-apply--ignore-whitespace-p s type scope)) + (`(untracked ,_ ,_) (user-error "Cannot unstage untracked changes")) + (`(unstaged file ,_) (magit-unstage-intent (list (oref s value)))) + (`(unstaged files ,_) (magit-unstage-intent (magit-region-values nil t))) + (`(unstaged ,_ ,_) (user-error "Already unstaged")) + (`(staged region ,_) (magit-apply-region s "--reverse" "--cached")) + (`(staged hunk ,_) (magit-apply-hunk s "--reverse" "--cached")) + (`(staged hunks ,_) (magit-apply-hunks s "--reverse" "--cached")) + ('(staged file t) (magit-apply-diff s "--reverse" "--cached")) + ('(staged files t) (magit-apply-diffs s "--reverse" "--cached")) + ('(staged list t) (magit-apply-diffs s "--reverse" "--cached")) + ('(staged file nil) (magit-unstage-1 (list (oref s value)))) + ('(staged files nil) (magit-unstage-1 (magit-region-values nil t))) + ('(staged list nil) (magit-unstage-all)) + (`(committed ,_ ,_) (if magit-unstage-committed + (magit-reverse-in-index) + (user-error "Cannot unstage committed changes"))) + (`(undefined ,_ ,_) (user-error "Cannot unstage this change"))))) + +;;;###autoload +(defun magit-unstage-files (files) + "Read one or more files and unstage all changes to those files." + (interactive + (let* ((choices (magit-staged-files)) + (default (or (magit-section-value-if 'file) + (magit-file-relative-name))) + (default (car (member default choices)))) + (list (magit-completing-read-multiple "Unstage file,s: " choices + nil t nil nil default)))) + (magit-with-toplevel + (magit-unstage-1 files))) + +(defun magit-unstage-1 (files) + (magit-wip-commit-before-change files " before unstage") + (if (magit-no-commit-p) + (magit-run-git "rm" "--cached" "--" files) + (magit-run-git "reset" "HEAD" "--" files)) + (magit-wip-commit-after-apply files " after unstage")) + +(defun magit-unstage-intent (files) + (if-let ((staged (magit-staged-files)) + (intent (seq-filter (##member % staged) files))) + (magit-unstage-1 intent) + (user-error "Already unstaged"))) + +;;;###autoload +(defun magit-unstage-all () + "Remove all changes from the staging area." + (interactive) + (unless (magit-anything-staged-p) + (user-error "Nothing to unstage")) + (when (or (magit-anything-unstaged-p) + (magit-untracked-files)) + (magit-confirm 'unstage-all-changes)) + (magit-wip-commit-before-change nil " before unstage") + (magit-run-git "reset" "HEAD" "--" magit-buffer-diff-files) + (magit-wip-commit-after-apply nil " after unstage")) + +(defvar magit-post-unstage-hook-commands + (list #'magit-unstage + #'magit-unstage-files + #'magit-unstage-all + 'magit-file-unstage)) + +(defun magit-run-post-unstage-hook () + (when (memq this-command magit-post-unstage-hook-commands) + (magit-run-hook-with-benchmark 'magit-post-unstage-hook))) + +;;;; Discard + +(defun magit-discard () + "Remove the change at point. + +On a hunk or file with unresolved conflicts prompt which side to +keep (while discarding the other). If point is within the text +of a side, then keep that side without prompting." + (interactive) + (when-let ((s (magit-apply--get-selection))) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(committed ,_) (user-error "Cannot discard committed changes")) + (`(undefined ,_) (user-error "Cannot discard this change")) + (`(untracked list) (magit-discard-untracked)) + (`(,_ region) (magit-discard-region s)) + (`(,_ hunk) (magit-discard-hunk s)) + (`(,_ hunks) (magit-discard-hunks s)) + (`(,_ file) (magit-discard-file s)) + (`(,_ files) (magit-discard-files s)) + (`(,_ list) (magit-discard-files s))))) + +(defun magit-discard-untracked () + (magit-discard-files--delete + (magit-with-toplevel (magit-list-untracked-files)) + nil) + (magit-refresh)) + +(defun magit-discard-region (section) + (magit-confirm 'discard "Discard region") + (magit-discard-apply section 'magit-apply-region)) + +(defun magit-discard-hunk (section) + (magit-confirm 'discard "Discard hunk") + (let ((file (magit-section-parent-value section))) + (pcase (cddr (car (magit-file-status file))) + ('(?U ?U) (magit-smerge-keep-current)) + (_ (magit-discard-apply section #'magit-apply-hunk))))) + +(defun magit-discard-apply (section apply) + (if (eq (magit-diff-type section) 'unstaged) + (funcall apply section "--reverse") + (if (magit-anything-unstaged-p + nil (if (magit-file-section-p section) + (oref section value) + (magit-section-parent-value section))) + (progn (let ((magit-inhibit-refresh t)) + (funcall apply section "--reverse" "--cached") + (funcall apply section "--reverse" "--reject")) + (magit-refresh)) + (funcall apply section "--reverse" "--index")))) + +(defun magit-discard-hunks (sections) + (magit-confirm 'discard + (list "Discard %d hunks from %s" + (length sections) + (magit-section-parent-value (car sections)))) + (magit-discard-apply-n sections #'magit-apply-hunks)) + +(defun magit-discard-apply-n (sections apply) + (let ((section (car sections))) + (if (eq (magit-diff-type section) 'unstaged) + (funcall apply sections "--reverse") + (if (magit-anything-unstaged-p + nil (if (magit-file-section-p section) + (oref section value) + (magit-section-parent-value section))) + (progn (let ((magit-inhibit-refresh t)) + (funcall apply sections "--reverse" "--cached") + (funcall apply sections "--reverse" "--reject")) + (magit-refresh)) + (funcall apply sections "--reverse" "--index"))))) + +(defun magit-discard-file (section) + (magit-discard-files (list section))) + +(defun magit-discard-files (sections) + (let ((auto-revert-verbose nil) + (type (magit-diff-type (car sections))) + (status (magit-file-status)) + files delete resurrect rename discard discard-new resolve) + (dolist (section sections) + (let ((file (oref section value))) + (push file files) + (pcase (cons (pcase type + (`staged ?X) + (`unstaged ?Y) + (`untracked ?Z)) + (cddr (assoc file status))) + ('(?Z) (dolist (f (magit-untracked-files nil file)) + (push f delete))) + ((or '(?Z ?? ??) '(?Z ?! ?!)) (push file delete)) + ('(?Z ?D ? ) (push file delete)) + (`(,_ ?D ?D) (push file resolve)) + ((or `(,_ ?U ,_) `(,_ ,_ ?U)) (push file resolve)) + (`(,_ ?A ?A) (push file resolve)) + (`(?X ?M ,(or ? ?M ?D)) (push section discard)) + (`(?Y ,_ ?M ) (push section discard)) + ('(?X ?A ?M ) (push file discard-new)) + ('(?X ?C ?M ) (push file discard-new)) + (`(?X ?A ,(or ? ?D)) (push file delete)) + (`(?X ?C ,(or ? ?D)) (push file delete)) + (`(?X ?D ,(or ? ?M )) (push file resurrect)) + (`(?Y ,_ ?D ) (push file resurrect)) + (`(?X ?R ,(or ? ?M ?D)) (push file rename))))) + (unwind-protect + (let ((magit-inhibit-refresh t)) + (magit-wip-commit-before-change files " before discard") + (when resolve + (magit-discard-files--resolve (nreverse resolve))) + (when resurrect + (magit-discard-files--resurrect (nreverse resurrect))) + (when delete + (magit-discard-files--delete (nreverse delete) status)) + (when rename + (magit-discard-files--rename (nreverse rename) status)) + (when (or discard discard-new) + (magit-discard-files--discard (nreverse discard) + (nreverse discard-new))) + (magit-wip-commit-after-apply files " after discard")) + (magit-refresh)))) + +(defun magit-discard-files--resolve (files) + (if-let ((arg (and (cdr files) + (magit-read-char-case + (format "For these %d files\n%s\ncheckout:\n" + (length files) + (mapconcat (##concat " " %) files "\n")) + t + (?o "[o]ur stage" "--ours") + (?t "[t]heir stage" "--theirs") + (?c "[c]onflict" "--merge") + (?i "decide [i]ndividually" nil))))) + (dolist (file files) + (magit-checkout-stage file arg)) + (dolist (file files) + (magit-checkout-stage file (magit-checkout-read-stage file))))) + +(defun magit-discard-files--resurrect (files) + (magit-confirm-files 'resurrect files) + (if (eq (magit-diff-type) 'staged) + (magit-call-git "reset" "--" files) + (magit-call-git "checkout" "--" files))) + +(defun magit-discard-files--delete (files status) + (magit-confirm-files (if magit-delete-by-moving-to-trash 'trash 'delete) + files) + (let ((delete-by-moving-to-trash magit-delete-by-moving-to-trash)) + (dolist (file files) + (when (string-match-p "\\`\\\\?~" file) + (error "Refusing to delete %S, too dangerous" file)) + (pcase (nth 3 (assoc file status)) + ((guard (memq (magit-diff-type) '(unstaged untracked))) + (dired-delete-file file dired-recursive-deletes + magit-delete-by-moving-to-trash) + (dired-clean-up-after-deletion file)) + (?\s (delete-file file t) + (magit-call-git "rm" "--cached" "--" file)) + (?M (let ((temp (magit-git-string "checkout-index" "--temp" file))) + (string-match + (format "\\(.+?\\)\t%s" (regexp-quote file)) temp) + (rename-file (match-string 1 temp) + (setq temp (concat file ".~{index}~"))) + (delete-file temp t)) + (magit-call-git "rm" "--cached" "--force" "--" file)) + (?D (magit-call-git "checkout" "--" file) + (delete-file file t) + (magit-call-git "rm" "--cached" "--force" "--" file)))))) + +(defun magit-discard-files--rename (files status) + (magit-confirm 'rename "Undo rename %s" "Undo %d renames" nil + (mapcar (lambda (file) + (setq file (assoc file status)) + (format "%s -> %s" (cadr file) (car file))) + files)) + (dolist (file files) + (let ((orig (cadr (assoc file status)))) + (if (file-exists-p file) + (progn + (when-let ((path (file-name-directory orig))) + (make-directory path t)) + (magit-call-git "mv" file orig)) + (magit-call-git "rm" "--cached" "--" file) + (magit-call-git "reset" "--" orig))))) + +(defun magit-discard-files--discard (sections new-files) + (let ((files (mapcar (##oref % value) sections))) + (magit-confirm-files 'discard (append files new-files) + (format "Discard %s changes in" (magit-diff-type))) + (if (eq (magit-diff-type (car sections)) 'unstaged) + (magit-call-git "checkout" "--" files) + (when new-files + (magit-call-git "add" "--" new-files) + (magit-call-git "reset" "--" new-files)) + (let ((binaries (magit-binary-files "--cached"))) + (when binaries + (setq sections + (seq-remove (##member (oref % value) binaries) + sections))) + (cond ((length= sections 1) + (magit-discard-apply (car sections) 'magit-apply-diff)) + (sections + (magit-discard-apply-n sections #'magit-apply-diffs))) + (when binaries + (let ((modified (magit-unstaged-files t))) + (setq binaries (magit--separate (##member % modified) binaries))) + (when (cadr binaries) + (magit-call-git "reset" "--" (cadr binaries))) + (when (car binaries) + (user-error + (concat + "Cannot discard staged changes to binary files, " + "which also have unstaged changes. Unstage instead.")))))))) + +;;;; Reverse + +(defun magit-reverse (&rest args) + "Reverse the change at point in the working tree. +With a prefix argument fallback to a 3-way merge. Doing +so causes the change to be applied to the index as well." + (interactive (and current-prefix-arg (list "--3way"))) + (when-let ((s (magit-apply--get-selection))) + (pcase (list (magit-diff-type) (magit-diff-scope)) + (`(untracked ,_) (user-error "Cannot reverse untracked changes")) + (`(unstaged ,_) (user-error "Cannot reverse unstaged changes")) + (`(,_ region) (magit-reverse-region s args)) + (`(,_ hunk) (magit-reverse-hunk s args)) + (`(,_ hunks) (magit-reverse-hunks s args)) + (`(,_ file) (magit-reverse-file s args)) + (`(,_ files) (magit-reverse-files s args)) + (`(,_ list) (magit-reverse-files s args))))) + +(defun magit-reverse-region (section args) + (magit-confirm 'reverse "Reverse region") + (magit-reverse-apply section #'magit-apply-region args)) + +(defun magit-reverse-hunk (section args) + (magit-confirm 'reverse "Reverse hunk") + (magit-reverse-apply section #'magit-apply-hunk args)) + +(defun magit-reverse-hunks (sections args) + (magit-confirm 'reverse + (list "Reverse %d hunks from %s" + (length sections) + (magit-section-parent-value (car sections)))) + (magit-reverse-apply sections #'magit-apply-hunks args)) + +(defun magit-reverse-file (section args) + (magit-reverse-files (list section) args)) + +(defun magit-reverse-files (sections args) + (pcase-let ((`(,binaries ,sections) + (let ((bs (magit-binary-files + (cond ((derived-mode-p 'magit-revision-mode) + magit-buffer-range) + ((derived-mode-p 'magit-diff-mode) + magit-buffer-range) + (t + "--cached"))))) + (magit--separate (##member (oref % value) bs) + sections)))) + (magit-confirm-files 'reverse (mapcar (##oref % value) sections)) + (cond ((length= sections 1) + (magit-reverse-apply (car sections) #'magit-apply-diff args)) + (sections + (magit-reverse-apply sections #'magit-apply-diffs args))) + (when binaries + (user-error "Cannot reverse binary files")))) + +(defun magit-reverse-apply (section:s apply args) + (funcall apply section:s "--reverse" args + (and (not magit-reverse-atomically) + (not (member "--3way" args)) + "--reject"))) + +(defun magit-reverse-in-index (&rest args) + "Reverse the change at point in the index but not the working tree. + +Use this command to extract a change from `HEAD', while leaving +it in the working tree, so that it can later be committed using +a separate commit. A typical workflow would be: + +0. Optionally make sure that there are no uncommitted changes. +1. Visit the `HEAD' commit and navigate to the change that should + not have been included in that commit. +2. Type \"u\" (`magit-unstage') to reverse it in the index. + This assumes that `magit-unstage-committed' is non-nil. +3. Type \"c e\" to extend `HEAD' with the staged changes, + including those that were already staged before. +4. Optionally stage the remaining changes using \"s\" or \"S\" + and then type \"c c\" to create a new commit." + (interactive) + (magit-reverse (cons "--cached" args))) + +;;; Smerge Support + +(defun magit-smerge-keep-current () + "Keep the current version of the conflict at point." + (interactive) + (magit-call-smerge #'smerge-keep-current)) + +(defun magit-smerge-keep-upper () + "Keep the upper/our version of the conflict at point." + (interactive) + (magit-call-smerge #'smerge-keep-upper)) + +(defun magit-smerge-keep-base () + "Keep the base version of the conflict at point." + (interactive) + (magit-call-smerge #'smerge-keep-base)) + +(defun magit-smerge-keep-lower () + "Keep the lower/their version of the conflict at point." + (interactive) + (magit-call-smerge #'smerge-keep-lower)) + +(defun magit-smerge-keep-all () + "Keep all versions of the conflict at point." + (interactive) + (magit-call-smerge #'smerge-keep-all)) + +(defun magit-call-smerge (fn) + (pcase-let* ((file (magit-file-at-point t t)) + (keep (get-file-buffer file)) + (`(,buf ,pos) + (let ((magit-diff-visit-jump-to-change nil)) + (magit-diff-visit-file--noselect file)))) + (with-current-buffer buf + (save-excursion + (save-restriction + (unless (<= (point-min) pos (point-max)) + (widen)) + (goto-char pos) + (condition-case nil + (smerge-match-conflict) + (error + (if (eq fn #'smerge-keep-current) + (when (eq this-command #'magit-discard) + (re-search-forward smerge-begin-re nil t) + (setq fn + (magit-read-char-case "Keep side: " t + (?o "[o]urs/upper" #'smerge-keep-upper) + (?b "[b]ase" #'smerge-keep-base) + (?t "[t]heirs/lower" #'smerge-keep-lower)))) + (re-search-forward smerge-begin-re nil t)))) + (funcall fn))) + (when (and keep (magit-anything-unmerged-p file)) + (smerge-start-session)) + (save-buffer)) + (unless keep + (kill-buffer buf)) + (magit-refresh))) + +;;; _ +(provide 'magit-apply) +;;; magit-apply.el ends here blob - /dev/null blob + e79c4fe7378ca9128fd6e70a00d2eeea484ab748 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-autoloads.el @@ -0,0 +1,2358 @@ +;;; magit-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from git-commit.el + +(put 'git-commit-major-mode 'safe-local-variable + (lambda (val) + (memq val '(text-mode + markdown-mode + org-mode + fundamental-mode + log-edit-mode + git-commit-elisp-text-mode)))) +(register-definition-prefixes "git-commit" '("git-commit-" "global-git-commit-mode")) + + +;;; Generated autoloads from git-rebase.el + +(autoload 'git-rebase-current-line "git-rebase" "\ +Parse current line into a `git-rebase-action' instance. +If the current line isn't recognized as a rebase line, an +instance with all nil values is returned, unless optional +BATCH is non-nil, in which case nil is returned. Non-nil +BATCH also ignores commented lines. + +(fn &optional BATCH)") +(autoload 'git-rebase-mode "git-rebase" "\ +Major mode for editing of a Git rebase file. + +Rebase files are generated when you run \"git rebase -i\" or run +`magit-interactive-rebase'. They describe how Git should perform +the rebase. See the documentation for git-rebase (e.g., by +running \"man git-rebase\" at the command line) for details. + +(fn)" t) +(defconst git-rebase-filename-regexp "/git-rebase-todo\\'") +(add-to-list 'auto-mode-alist (cons git-rebase-filename-regexp #'git-rebase-mode)) +(register-definition-prefixes "git-rebase" '("git-rebase-" "magit-imenu--rebase-")) + + +;;; Generated autoloads from magit.el + +(defvar magit-define-global-key-bindings 'default "\ +Which set of key bindings to add to the global keymap, if any. + +This option controls which set of Magit key bindings, if any, may +be added to the global keymap, even before Magit is first used in +the current Emacs session. + +If the value is nil, no bindings are added. + +If \\+`default', maybe add: + + \\`C-x' \\`g' `magit-status' + \\`C-x' \\`M-g' `magit-dispatch' + \\`C-c' \\`M-g' `magit-file-dispatch' + +If `recommended', maybe add: + + \\`C-x' \\`g' `magit-status' + \\`C-c' \\`g' `magit-dispatch' + \\`C-c' \\`f' `magit-file-dispatch' + + These bindings are strongly recommended, but we cannot use + them by default, because the \\`C-c ' namespace is + strictly reserved for bindings added by the user. + +The bindings in the chosen set may be added when +`after-init-hook' is run. Each binding is added if, and only +if, at that time no other key is bound to the same command, +and no other command is bound to the same key. In other words +we try to avoid adding bindings that are unnecessary, as well +as bindings that conflict with other bindings. + +Adding these bindings is delayed until `after-init-hook' is +run to allow users to set the variable anywhere in their init +file (without having to make sure to do so before `magit' is +loaded or autoloaded) and to increase the likelihood that all +the potentially conflicting user bindings have already been +added. + +To set this variable use either `setq' or the Custom interface. +Do not use the function `customize-set-variable' because doing +that would cause Magit to be loaded immediately, when that form +is evaluated (this differs from `custom-set-variables', which +doesn't load the libraries that define the customized variables). + +Setting this variable has no effect if `after-init-hook' has +already been run.") +(custom-autoload 'magit-define-global-key-bindings "magit" t) +(defun magit-maybe-define-global-key-bindings (&optional force) "\ +See variable `magit-define-global-key-bindings'." (when magit-define-global-key-bindings (let ((map (current-global-map))) (pcase-dolist (`(,key \, def) (cond ((eq magit-define-global-key-bindings 'recommended) '(("C-x g" . magit-status) ("C-c g" . magit-dispatch) ("C-c f" . magit-file-dispatch))) ('(("C-x g" . magit-status) ("C-x M-g" . magit-dispatch) ("C-c M-g" . magit-file-dispatch))))) (when (or force (not (or (lookup-key map (kbd key)) (where-is-internal def (make-sparse-keymap) t)))) (define-key map (kbd key) def)))))) +(if after-init-time (magit-maybe-define-global-key-bindings) (add-hook 'after-init-hook #'magit-maybe-define-global-key-bindings t)) + (autoload 'magit-dispatch "magit" nil t) + (autoload 'magit-run "magit" nil t) +(autoload 'magit-git-command "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +With a prefix argument COMMAND is run in the top-level directory +of the current working tree, otherwise in `default-directory'. + +(fn COMMAND)" t) +(autoload 'magit-git-command-topdir "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +COMMAND is run in the top-level directory of the current +working tree. + +(fn COMMAND)" t) +(autoload 'magit-shell-command "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. With a +prefix argument COMMAND is run in the top-level directory of +the current working tree, otherwise in `default-directory'. + +(fn COMMAND)" t) +(autoload 'magit-shell-command-topdir "magit" "\ +Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. COMMAND +is run in the top-level directory of the current working tree. + +(fn COMMAND)" t) +(autoload 'magit-version "magit" "\ +Return the version of Magit currently in use. + +If optional argument PRINT-DEST is non-nil, also print the used +versions of Magit, Transient, Git and Emacs to the output stream +selected by that argument. Interactively use the echo area, or +with a prefix argument use the current buffer. Additionally put +the output in the kill ring. + +(fn &optional PRINT-DEST)" t) +(register-definition-prefixes "magit" '("magit-")) + + +;;; Generated autoloads from magit-apply.el + +(autoload 'magit-stage-files "magit-apply" "\ +Read one or more files and stage all changes in those files. +With prefix argument FORCE, offer ignored files for completion. + +(fn FILES &optional FORCE)" t) +(autoload 'magit-stage-modified "magit-apply" "\ +Stage all changes to files modified in the worktree. +Stage all new content of tracked files and remove tracked files +that no longer exist in the working tree from the index also. +With a prefix argument also stage previously untracked (but not +ignored) files. + +(fn &optional ALL)" t) +(autoload 'magit-unstage-files "magit-apply" "\ +Read one or more files and unstage all changes to those files. + +(fn FILES)" t) +(autoload 'magit-unstage-all "magit-apply" "\ +Remove all changes from the staging area." t) +(register-definition-prefixes "magit-apply" '("magit-")) + + +;;; Generated autoloads from magit-autorevert.el + +(put 'magit-auto-revert-mode 'globalized-minor-mode t) +(defvar magit-auto-revert-mode (not (or global-auto-revert-mode noninteractive)) "\ +Non-nil if Magit-Auto-Revert mode is enabled. +See the `magit-auto-revert-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-auto-revert-mode'.") +(custom-autoload 'magit-auto-revert-mode "magit-autorevert" nil) +(autoload 'magit-auto-revert-mode "magit-autorevert" "\ +Toggle Auto-Revert mode in all buffers. +With prefix ARG, enable Magit-Auto-Revert mode if ARG is positive; +otherwise, disable it. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +Auto-Revert mode is enabled in all buffers where +`magit-turn-on-auto-revert-mode-if-desired' would do it. + +See `auto-revert-mode' for more information on Auto-Revert mode. + +(fn &optional ARG)" t) +(register-definition-prefixes "magit-autorevert" '("auto-revert-buffer" "magit-")) + + +;;; Generated autoloads from magit-base.el + +(autoload 'magit-emacs-Q-command "magit-base" "\ +Show a shell command that runs an uncustomized Emacs with only Magit loaded. +See info node `(magit)Debugging Tools' for more information." t) +(define-advice Info-follow-nearest-node (:around (fn &optional fork) gitman) (let ((node (Info-get-token (point) "\\*note[ + ]+" "\\*note[ + ]+\\([^:]*\\):\\(:\\|[ + ]*(\\)?"))) (if (and node (string-match "^(gitman)\\(.+\\)" node)) (pcase magit-view-git-manual-method ('info (funcall fn fork)) ('man (require 'man) (man (match-string 1 node))) ('woman (require 'woman) (woman (match-string 1 node))) (_ (user-error "Invalid value for `magit-view-git-manual-method'"))) (funcall fn fork)))) +(define-advice org-man-export (:around (fn link description format) gitman) (if (and (eq format 'texinfo) (string-prefix-p "git" link)) (string-replace "%s" link " +@ifinfo +@ref{%s,,,gitman,}. +@end ifinfo +@ifhtml +@html +the %s(1) manpage. +@end html +@end ifhtml +@iftex +the %s(1) manpage. +@end iftex +") (funcall fn link description format))) +(register-definition-prefixes "magit-base" '("magit-")) + + +;;; Generated autoloads from magit-bisect.el + + (autoload 'magit-bisect "magit-bisect" nil t) +(autoload 'magit-bisect-start "magit-bisect" "\ +Start a bisect session. + +Bisecting a bug means to find the commit that introduced it. +This command starts such a bisect session by asking for a known +good and a known bad commit. To move the session forward use the +other actions from the bisect transient command (\\\\[magit-bisect]). + +(fn BAD GOOD ARGS)" t) +(autoload 'magit-bisect-reset "magit-bisect" "\ +After bisecting, cleanup bisection state and return to original `HEAD'." t) +(autoload 'magit-bisect-good "magit-bisect" "\ +While bisecting, mark the current commit as good. +Use this after you have asserted that the commit does not contain +the bug in question." t) +(autoload 'magit-bisect-bad "magit-bisect" "\ +While bisecting, mark the current commit as bad. +Use this after you have asserted that the commit does contain the +bug in question." t) +(autoload 'magit-bisect-mark "magit-bisect" "\ +While bisecting, mark the current commit with a bisect term. +During a bisect using alternate terms, commits can still be +marked with `magit-bisect-good' and `magit-bisect-bad', as those +commands map to the correct term (\"good\" to --term-old's value +and \"bad\" to --term-new's). However, in some cases, it can be +difficult to keep that mapping straight in your head; this +command provides an interface that exposes the underlying terms." t) +(autoload 'magit-bisect-skip "magit-bisect" "\ +While bisecting, skip the current commit. +Use this if for some reason the current commit is not a good one +to test. This command lets Git choose a different one." t) +(autoload 'magit-bisect-run "magit-bisect" "\ +Bisect automatically by running commands after each step. + +Unlike `git bisect run' this can be used before bisecting has +begun. In that case it behaves like `git bisect start; git +bisect run'. + +(fn CMDLINE &optional BAD GOOD ARGS)" t) +(register-definition-prefixes "magit-bisect" '("magit-")) + + +;;; Generated autoloads from magit-blame.el + + (autoload 'magit-blame-echo "magit-blame" nil t) + (autoload 'magit-blame-addition "magit-blame" nil t) + (autoload 'magit-blame-removal "magit-blame" nil t) + (autoload 'magit-blame-reverse "magit-blame" nil t) + (autoload 'magit-blame "magit-blame" nil t) +(register-definition-prefixes "magit-blame" '("magit-")) + + +;;; Generated autoloads from magit-branch.el + + (autoload 'magit-branch "magit" nil t) +(autoload 'magit-checkout "magit-branch" "\ +Checkout REVISION, updating the index and the working tree. +If REVISION is a local branch, then that becomes the current +branch. If it is something else, then `HEAD' becomes detached. +Checkout fails if the working tree or the staging area contain +changes. + +(git checkout REVISION). + +(fn REVISION &optional ARGS)" t) +(function-put 'magit-checkout 'interactive-only 'magit--checkout) +(autoload 'magit-branch-create "magit-branch" "\ +Create BRANCH at branch or revision START-POINT. + +(fn BRANCH START-POINT)" t) +(function-put 'magit-branch-create 'interactive-only 'magit-call-git) +(autoload 'magit-branch-and-checkout "magit-branch" "\ +Create and checkout BRANCH at branch or revision START-POINT. + +(fn BRANCH START-POINT &optional ARGS)" t) +(function-put 'magit-branch-and-checkout 'interactive-only 'magit-call-git) +(autoload 'magit-branch-or-checkout "magit-branch" "\ +Hybrid between `magit-checkout' and `magit-branch-and-checkout'. + +Ask the user for an existing branch or revision. If the user +input actually can be resolved as a branch or revision, then +check that out, just like `magit-checkout' would. + +Otherwise create and checkout a new branch using the input as +its name. Before doing so read the starting-point for the new +branch. This is similar to what `magit-branch-and-checkout' +does. + +(fn ARG &optional START-POINT)" t) +(function-put 'magit-branch-or-checkout 'interactive-only 'magit-call-git) +(autoload 'magit-branch-checkout "magit-branch" "\ +Checkout an existing or new local branch. + +Read a branch name from the user offering all local branches and +a subset of remote branches as candidates. Omit remote branches +for which a local branch by the same name exists from the list +of candidates. The user can also enter a completely new branch +name. + +- If the user selects an existing local branch, then check that + out. + +- If the user selects a remote branch, then create and checkout + a new local branch with the same name. Configure the selected + remote branch as push target. + +- If the user enters a new branch name, then create and check + that out, after also reading the starting-point from the user. + +In the latter two cases the upstream is also set. Whether it is +set to the chosen START-POINT or something else depends on the +value of `magit-branch-adjust-remote-upstream-alist', just like +when using `magit-branch-and-checkout'. + +(fn BRANCH &optional START-POINT)" t) +(function-put 'magit-branch-checkout 'interactive-only 'magit-call-git) +(autoload 'magit-branch-orphan "magit-branch" "\ +Create and checkout an orphan BRANCH with contents from revision START-POINT. + +(fn BRANCH START-POINT)" t) +(autoload 'magit-branch-spinout "magit-branch" "\ +Create new branch from the unpushed commits. +Like `magit-branch-spinoff' but remain on the current branch. +If there are any uncommitted changes, then behave exactly like +`magit-branch-spinoff'. + +(fn BRANCH &optional FROM)" t) +(autoload 'magit-branch-spinoff "magit-branch" "\ +Create new branch from the unpushed commits. + +Create and checkout a new branch starting at and tracking the +current branch. That branch in turn is reset to the last commit +it shares with its upstream. If the current branch has no +upstream or no unpushed commits, then the new branch is created +anyway and the previously current branch is not touched. + +This is useful to create a feature branch after work has already +began on the old branch (likely but not necessarily \"master\"). + +If the current branch is a member of the value of option +`magit-branch-prefer-remote-upstream' (which see), then the +current branch will be used as the starting point as usual, but +the upstream of the starting-point may be used as the upstream +of the new branch, instead of the starting-point itself. + +If optional FROM is non-nil, then the source branch is reset +to `FROM~', instead of to the last commit it shares with its +upstream. Interactively, FROM is only ever non-nil, if the +region selects some commits, and among those commits, FROM is +the commit that is the fewest commits ahead of the source +branch. + +The commit at the other end of the selection actually does not +matter, all commits between FROM and `HEAD' are moved to the new +branch. If FROM is not reachable from `HEAD' or is reachable +from the source branch's upstream, then an error is raised. + +(fn BRANCH &optional FROM)" t) +(autoload 'magit-branch-reset "magit-branch" "\ +Reset a branch to the tip of another branch or any other commit. + +When the branch being reset is the current branch, then do a +hard reset. If there are any uncommitted changes, then the user +has to confirm the reset because those changes would be lost. + +This is useful when you have started work on a feature branch but +realize it's all crap and want to start over. + +When resetting to another branch and a prefix argument is used, +then also set the target branch as the upstream of the branch +that is being reset. + +(fn BRANCH TO &optional SET-UPSTREAM)" t) +(autoload 'magit-branch-delete "magit-branch" "\ +Delete one or multiple branches. + +If the region marks multiple branches, then offer to delete +those, otherwise prompt for a single branch to be deleted, +defaulting to the branch at point. + +Require confirmation when deleting branches is dangerous in some +way. Option `magit-no-confirm' can be customized to not require +confirmation in certain cases. See its docstring to learn why +confirmation is required by default in certain cases or if a +prompt is confusing. + +(fn BRANCHES &optional FORCE)" t) +(autoload 'magit-branch-rename "magit-branch" "\ +Rename the branch named OLD to NEW. + +With a prefix argument FORCE, rename even if a branch named NEW +already exists. + +If `branch.OLD.pushRemote' is set, then unset it. Depending on +the value of `magit-branch-rename-push-target' (which see) maybe +set `branch.NEW.pushRemote' and maybe rename the push-target on +the remote. + +(fn OLD NEW &optional FORCE)" t) +(autoload 'magit-branch-shelve "magit-branch" "\ +Shelve a BRANCH. +Rename \"refs/heads/BRANCH\" to \"refs/shelved/YYYY-MM-DD-BRANCH\", +and also rename the respective reflog file. + +(fn BRANCH)" t) +(autoload 'magit-branch-unshelve "magit-branch" "\ +Unshelve a BRANCH. +Rename \"refs/shelved/BRANCH\" to \"refs/heads/BRANCH\". If BRANCH +is prefixed with \"YYYY-MM-DD\", then drop that part of the name. +Also rename the respective reflog file. + +(fn BRANCH)" t) + (autoload 'magit-branch-configure "magit-branch" nil t) +(register-definition-prefixes "magit-branch" '("magit-")) + + +;;; Generated autoloads from magit-bundle.el + + (autoload 'magit-bundle "magit-bundle" nil t) + (autoload 'magit-bundle-import "magit-bundle" nil t) +(autoload 'magit-bundle-create-tracked "magit-bundle" "\ +Create and track a new bundle. + +(fn FILE TAG BRANCH REFS ARGS)" t) +(autoload 'magit-bundle-update-tracked "magit-bundle" "\ +Update a bundle that is being tracked using TAG. + +(fn TAG)" t) +(autoload 'magit-bundle-verify "magit-bundle" "\ +Check whether FILE is valid and applies to the current repository. + +(fn FILE)" t) +(autoload 'magit-bundle-list-heads "magit-bundle" "\ +List the refs in FILE. + +(fn FILE)" t) +(register-definition-prefixes "magit-bundle" '("magit-")) + + +;;; Generated autoloads from magit-clone.el + + (autoload 'magit-clone "magit-clone" nil t) +(autoload 'magit-clone-regular "magit-clone" "\ +Create a clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +(fn REPOSITORY DIRECTORY ARGS)" t) +(autoload 'magit-clone-shallow "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +With a prefix argument read the DEPTH of the clone; +otherwise use 1. + +(fn REPOSITORY DIRECTORY ARGS DEPTH)" t) +(autoload 'magit-clone-shallow-since "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits before DATE, which is read from the +user. + +(fn REPOSITORY DIRECTORY ARGS DATE)" t) +(autoload 'magit-clone-shallow-exclude "magit-clone" "\ +Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits reachable from EXCLUDE, which is a +branch or tag read from the user. + +(fn REPOSITORY DIRECTORY ARGS EXCLUDE)" t) +(autoload 'magit-clone-bare "magit-clone" "\ +Create a bare clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +(fn REPOSITORY DIRECTORY ARGS)" t) +(autoload 'magit-clone-mirror "magit-clone" "\ +Create a mirror of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. + +(fn REPOSITORY DIRECTORY ARGS)" t) +(autoload 'magit-clone-sparse "magit-clone" "\ +Clone REPOSITORY into DIRECTORY and create a sparse checkout. + +(fn REPOSITORY DIRECTORY ARGS)" t) +(register-definition-prefixes "magit-clone" '("magit-")) + + +;;; Generated autoloads from magit-commit.el + + (autoload 'magit-commit "magit-commit" nil t) +(autoload 'magit-commit-create "magit-commit" "\ +Create a new commit. + +(fn &optional ARGS)" t) +(autoload 'magit-commit-extend "magit-commit" "\ +Amend staged changes to the last commit, without editing its message. + +With a prefix argument do not update the committer date; without an +argument update it. The option `magit-commit-extend-override-date' +can be used to inverse the meaning of the prefix argument. Called +non-interactively, the optional OVERRIDE-DATE argument controls this +behavior, and the option is of no relevance. + +(fn &optional ARGS OVERRIDE-DATE)" t) +(autoload 'magit-commit-amend "magit-commit" "\ +Amend staged changes (if any) to the last commit, and edit its message. + +(fn &optional ARGS)" t) +(autoload 'magit-commit-reword "magit-commit" "\ +Reword the message of the last commit, without amending its tree. + +With a prefix argument do not update the committer date; without an +argument update it. The option `magit-commit-reword-override-date' +can be used to inverse the meaning of the prefix argument. Called +non-interactively, the optional OVERRIDE-DATE argument controls this +behavior, and the option is of no relevance. + +(fn &optional ARGS OVERRIDE-DATE)" t) +(autoload 'magit-commit-fixup "magit-commit" "\ +Create a fixup commit, leaving the original commit message untouched. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the original message of the targeted commit is used as-is. + +In other words, call \"git commit --fixup=COMMIT --no-edit\". + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-squash "magit-commit" "\ +Create a squash commit, without the user authoring a commit message. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the user is given a chance to edit the original message to take +the changes from the squash commit into account. + +In other words, call \"git commit --squash=COMMIT --no-edit\". + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-alter "magit-commit" "\ +Create a squash commit, authoring the final commit message now. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the original message of the targeted commit is replaced with the +message of this commit, without the user automatically being given a +chance to edit again. + +In other words, call \"git commit --fixup=amend:COMMIT --edit\". + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-augment "magit-commit" "\ +Create a squash commit, authoring a new temporary commit message. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the user is asked to write a final commit message, in a buffer +that starts out containing both the original commit message, as well as +the temporary commit message of the squash commit. + +In other words, call \"git commit --squash=COMMIT --edit\". + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-revise "magit-commit" "\ +Reword the message of an existing commit, without editing its tree. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, a combined commit is created which uses the message of the fixup +commit and the tree of the targeted commit. + +In other words, call \"git commit --fixup=reword:COMMIT --edit\". + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-instant-fixup "magit-commit" "\ +Create a fixup commit, and immediately combine it with its target. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +Leave the original commit message of the targeted commit untouched. + +Like `magit-commit-fixup' but also run a `--autofixup' rebase. + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-instant-squash "magit-commit" "\ +Create a squash commit, and immediately combine it with its target. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +Turing the rebase phase, when the two commits are being squashed, ask +the user to author the final commit message, based on the original +message of the targeted commit. + +Like `magit-commit-squash' but also run a `--autofixup' rebase. + +(fn &optional COMMIT ARGS)" t) +(autoload 'magit-commit-reshelve "magit-commit" "\ +Change committer (and possibly author) date of the last commit. + +The current time is used as the initial minibuffer input and the +original author or committer date is available as the previous +history element. + +Both the author and the committer dates are changed, unless one +of the following is true, in which case only the committer date +is updated: +- You are not the author of the commit that is being reshelved. +- The command was invoked with a prefix argument. +- Non-interactively if UPDATE-AUTHOR is nil. + +(fn DATE UPDATE-AUTHOR &optional ARGS)" t) +(autoload 'magit-commit-absorb-modules "magit-commit" "\ +Spread modified modules across recent commits. + +(fn PHASE COMMIT)" t) + (autoload 'magit-commit-absorb "magit-commit" nil t) + (autoload 'magit-commit-autofixup "magit-commit" nil t) +(register-definition-prefixes "magit-commit" '("magit-")) + + +;;; Generated autoloads from magit-diff.el + + (autoload 'magit-diff "magit-diff" nil t) + (autoload 'magit-diff-refresh "magit-diff" nil t) +(autoload 'magit-diff-dwim "magit-diff" "\ +Show changes for the thing at point. + +For example, if point is on a commit, show the changes introduced by +that commit. Likewise if point is on the section titled \"Unstaged +changes\", then show those changes in a separate buffer. Generally +speaking, compare the thing at point with the most logical, trivial +and (in *any* situation) at least potentially useful other thing it +could be compared to. + +When the region selects commits, then compare the two commits at +either end. There are different ways two commits can be compared. +In the buffer showing the diff, you can control how the comparison, +is done, using \"D r\" and \"D f\". + +This function does not always show the changes that you might want +to view in any given situation. You can think of the changes being +shown as the smallest common denominator. There is no AI involved. +If this command never does what you want, then ignore it, and instead +use the commands that allow you to explicitly specify what you need. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-diff-range "magit-diff" "\ +Show differences between two commits. + +REV-OR-RANGE should be a range or a single revision. If it is a +revision, then show changes in the working tree relative to that +revision. If it is a range, but one side is omitted, then show +changes relative to `HEAD'. + +If the region is active, use the revisions on the first and last +line of the region as the two sides of the range. With a prefix +argument, instead of diffing the revisions, choose a revision to +view changes along, starting at the common ancestor of both +revisions (i.e., use a \"...\" range). + +(fn REV-OR-RANGE &optional ARGS FILES)" t) +(autoload 'magit-diff-working-tree "magit-diff" "\ +Show changes between the current working tree and the `HEAD' commit. +With a prefix argument show changes between the working tree and +a commit read from the minibuffer. + +(fn &optional REV ARGS FILES)" t) +(autoload 'magit-diff-staged "magit-diff" "\ +Show changes between the index and the `HEAD' commit. +With a prefix argument show changes between the index and +a commit read from the minibuffer. + +(fn &optional REV ARGS FILES)" t) +(autoload 'magit-diff-unstaged "magit-diff" "\ +Show changes between the working tree and the index. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-diff-unmerged "magit-diff" "\ +Show changes that are being merged. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-diff-while-committing "magit-diff" "\ +While committing, show the changes that are about to be committed. +While amending, invoking the command again toggles between +showing just the new changes or all the changes that will +be committed." t) +(autoload 'magit-diff-buffer-file "magit-diff" "\ +Show diff for the blob or file visited in the current buffer. + +When the buffer visits a blob, then show the respective commit. +When the buffer visits a file, then show the differences between +`HEAD' and the working tree. In both cases limit the diff to +the file or blob." t) +(autoload 'magit-diff-paths "magit-diff" "\ +Show changes between any two files on disk. + +(fn A B)" t) +(autoload 'magit-show-commit "magit-diff" "\ +Visit the revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision. + +(fn REV &optional ARGS FILES MODULE)" t) +(register-definition-prefixes "magit-diff" '("magit-")) + + +;;; Generated autoloads from magit-dired.el + +(autoload 'magit-dired-jump "magit-dired" "\ +Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'. + +(fn &optional OTHER-WINDOW)" t) +(autoload 'magit-dired-stage "magit-dired" "\ +In Dired, staged all marked files or the file at point." t) +(autoload 'magit-dired-unstage "magit-dired" "\ +In Dired, unstaged all marked files or the file at point." t) +(autoload 'magit-dired-log "magit-dired" "\ +In Dired, show log for all marked files or the directory if none are marked. + +(fn &optional FOLLOW)" t) +(autoload 'magit-dired-am-apply-patches "magit-dired" "\ +In Dired, apply the marked (or next ARG) files as patches. +If inside a repository, then apply in that. Otherwise prompt +for a repository. + +(fn REPO &optional ARG)" t) +(autoload 'magit-do-async-shell-command "magit-dired" "\ +Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point. + +(fn FILE)" t) + + +;;; Generated autoloads from magit-ediff.el + + (autoload 'magit-ediff "magit-ediff" nil) +(autoload 'magit-ediff-resolve-all "magit-ediff" "\ +Resolve all conflicts in the FILE at point using Ediff. + +If there is no file at point or if it doesn't have any unmerged +changes, then prompt for a file. + +See info node `(magit) Ediffing' for more information about this +and alternative commands. + +(fn FILE)" t) +(autoload 'magit-ediff-resolve-rest "magit-ediff" "\ +Resolve outstanding conflicts in the FILE at point using Ediff. + +If there is no file at point or if it doesn't have any unmerged +changes, then prompt for a file. + +See info node `(magit) Ediffing' for more information about this +and alternative commands. + +(fn FILE)" t) +(autoload 'magit-ediff-stage "magit-ediff" "\ +Stage and unstage changes to FILE using Ediff. +FILE has to be relative to the top directory of the repository. + +(fn FILE)" t) +(autoload 'magit-ediff-compare "magit-ediff" "\ +Compare REVA:FILEA with REVB:FILEB using Ediff. + +FILEA and FILEB have to be relative to the top directory of the +repository. If REVA or REVB is nil, then this stands for the +working tree state. + +If the region is active, use the revisions on the first and last +line of the region. With a prefix argument, instead of diffing +the revisions, choose a revision to view changes along, starting +at the common ancestor of both revisions (i.e., use a \"...\" +range). + +(fn REVA REVB FILEA FILEB)" t) +(autoload 'magit-ediff-dwim "magit-ediff" "\ +Compare, stage, or resolve using Ediff. +This command tries to guess what file, and what commit or range +the user wants to compare, stage, or resolve using Ediff. It +might only be able to guess either the file, or range or commit, +in which case the user is asked about the other. It might not +always guess right, in which case the appropriate `magit-ediff-*' +command has to be used explicitly. If it cannot read the user's +mind at all, then it asks the user for a command to run." t) +(autoload 'magit-ediff-show-staged "magit-ediff" "\ +Show staged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository. + +(fn FILE)" t) +(autoload 'magit-ediff-show-unstaged "magit-ediff" "\ +Show unstaged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository. + +(fn FILE)" t) +(autoload 'magit-ediff-show-working-tree "magit-ediff" "\ +Show changes between `HEAD' and working tree using Ediff. +FILE must be relative to the top directory of the repository. + +(fn FILE)" t) +(autoload 'magit-ediff-show-commit "magit-ediff" "\ +Show changes introduced by COMMIT using Ediff. + +(fn COMMIT)" t) +(autoload 'magit-ediff-show-stash "magit-ediff" "\ +Show changes introduced by STASH using Ediff. +`magit-ediff-show-stash-with-index' controls whether a +three-buffer Ediff is used in order to distinguish changes in the +stash that were staged. + +(fn STASH)" t) +(register-definition-prefixes "magit-ediff" '("magit-ediff-")) + + +;;; Generated autoloads from magit-extras.el + + (autoload 'magit-git-mergetool "magit-extras" nil t) +(autoload 'magit-run-git-gui-blame "magit-extras" "\ +Run `git gui blame' on the given FILENAME and COMMIT. +Interactively run it for the current file and the `HEAD', with a +prefix or when the current file cannot be determined let the user +choose. When the current buffer is visiting FILENAME instruct +blame to center around the line point is on. + +(fn COMMIT FILENAME &optional LINENUM)" t) +(autoload 'magit-run-git-gui "magit-extras" "\ +Run `git gui' for the current git repository." t) +(autoload 'magit-run-gitk "magit-extras" "\ +Run `gitk' in the current repository." t) +(autoload 'magit-run-gitk-branches "magit-extras" "\ +Run `gitk --branches' in the current repository." t) +(autoload 'magit-run-gitk-all "magit-extras" "\ +Run `gitk --all' in the current repository." t) +(autoload 'magit-project-status "magit-extras" "\ +Run `magit-status' in the current project's root." t) +(autoload 'magit-previous-line "magit-extras" "\ +Like `previous-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects an +area that is larger than the region. This causes `previous-line' +when invoked while holding the shift key to move up one line and +thereby select two lines. When invoked inside a hunk body this +command does not move point on the first invocation and thereby +it only selects a single line. Which inconsistency you prefer +is a matter of preference. + +(fn &optional ARG TRY-VSCROLL)" t) +(function-put 'magit-previous-line 'interactive-only '"use `forward-line' with negative argument instead.") +(autoload 'magit-next-line "magit-extras" "\ +Like `next-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects +an area that is larger than the region. This causes `next-line' +when invoked while holding the shift key to move down one line +and thereby select two lines. When invoked inside a hunk body +this command does not move point on the first invocation and +thereby it only selects a single line. Which inconsistency you +prefer is a matter of preference. + +(fn &optional ARG TRY-VSCROLL)" t) +(function-put 'magit-next-line 'interactive-only 'forward-line) +(autoload 'magit-clean "magit-extras" "\ +Remove untracked files from the working tree. +With a prefix argument also remove ignored files, +with two prefix arguments remove ignored files only. + +(git clean -f -d [-x|-X]) + +(fn &optional ARG)" t) +(autoload 'magit-generate-changelog "magit-extras" "\ +Insert ChangeLog entries into the current buffer. + +The entries are generated from the diff being committed. +If prefix argument, AMENDING, is non-nil, include changes +in HEAD as well as staged changes in the diff to check. + +(fn &optional AMENDING)" t) +(autoload 'magit-add-change-log-entry "magit-extras" "\ +Find change log file and add date entry and item for current change. +This differs from `add-change-log-entry' (which see) in that +it acts on the current hunk in a Magit buffer instead of on +a position in a file-visiting buffer. + +(fn &optional WHOAMI FILE-NAME OTHER-WINDOW)" t) +(autoload 'magit-add-change-log-entry-other-window "magit-extras" "\ +Find change log file in other window and add entry and item. +This differs from `add-change-log-entry-other-window' (which see) +in that it acts on the current hunk in a Magit buffer instead of +on a position in a file-visiting buffer. + +(fn &optional WHOAMI FILE-NAME)" t) +(autoload 'magit-edit-line-commit "magit-extras" "\ +Edit the commit that added the current line. + +With a prefix argument edit the commit that removes the line, +if any. The commit is determined using `git blame' and made +editable using `git rebase --interactive' if it is reachable +from `HEAD', or by checking out the commit (or a branch that +points at it) otherwise. + +(fn &optional TYPE)" t) +(autoload 'magit-diff-edit-hunk-commit "magit-extras" "\ +From a hunk, edit the respective commit and visit the file. + +First visit the file being modified by the hunk at the correct +location using `magit-diff-visit-file'. This actually visits a +blob. When point is on a diff header, not within an individual +hunk, then this visits the blob the first hunk is about. + +Then invoke `magit-edit-line-commit', which uses an interactive +rebase to make the commit editable, or if that is not possible +because the commit is not reachable from `HEAD' by checking out +that commit directly. This also causes the actual worktree file +to be visited. + +Neither the blob nor the file buffer are killed when finishing +the rebase. If that is undesirable, then it might be better to +use `magit-rebase-edit-commit' instead of this command. + +(fn FILE)" t) +(autoload 'magit-reshelve-since "magit-extras" "\ +Change the author and committer dates of the commits since REV. + +Ask the user for the first reachable commit whose dates should +be changed. Then read the new date for that commit. The initial +minibuffer input and the previous history element offer good +values. The next commit will be created one minute later and so +on. + +This command is only intended for interactive use and should only +be used on highly rearranged and unpublished history. + +If KEYID is non-nil, then use that to sign all reshelved commits. +Interactively use the value of the \"--gpg-sign\" option in the +list returned by `magit-rebase-arguments'. + +(fn REV KEYID)" t) +(autoload 'magit-pop-revision-stack "magit-extras" "\ +Insert a representation of a revision into the current buffer. + +Pop a revision from the `magit-revision-stack' and insert it into +the current buffer according to `magit-pop-revision-stack-format'. +Revisions can be put on the stack using `magit-copy-section-value' +and `magit-copy-buffer-revision'. + +If the stack is empty or with a prefix argument, instead read a +revision in the minibuffer. By using the minibuffer history this +allows selecting an item which was popped earlier or to insert an +arbitrary reference or revision without first pushing it onto the +stack. + +When reading the revision from the minibuffer, then it might not +be possible to guess the correct repository. When this command +is called inside a repository (e.g., while composing a commit +message), then that repository is used. Otherwise (e.g., while +composing an email) then the repository recorded for the top +element of the stack is used (even though we insert another +revision). If not called inside a repository and with an empty +stack, or with two prefix arguments, then read the repository in +the minibuffer too. + +(fn REV TOPLEVEL)" t) +(autoload 'magit-copy-section-value "magit-extras" "\ +Save the value of the current section for later use. + +Save the section value to the `kill-ring', and, provided that +the current section is a commit, branch, or tag section, push +the (referenced) revision to the `magit-revision-stack' for use +with `magit-pop-revision-stack'. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'. + +When the current section is a branch or a tag, and a prefix +argument is used, then save the revision at its tip to the +`kill-ring' instead of the reference name. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. If a prefix argument is used and the region is within +a hunk, then strip the diff marker column and keep only either +the added or removed lines, depending on the sign of the prefix +argument. + +(fn ARG)" t) +(autoload 'magit-copy-buffer-revision "magit-extras" "\ +Save the revision of the current buffer for later use. + +Save the revision shown in the current buffer to the `kill-ring' +and push it to the `magit-revision-stack'. + +This command is mainly intended for use in `magit-revision-mode' +buffers, the only buffers where it is always unambiguous exactly +which revision should be saved. + +Most other Magit buffers usually show more than one revision, in +some way or another, so this command has to select one of them, +and that choice might not always be the one you think would have +been the best pick. + +In such buffers it is often more useful to save the value of +the current section instead, using `magit-copy-section-value'. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'." t) +(autoload 'magit-display-repository-buffer "magit-extras" "\ +Display a Magit buffer belonging to the current Git repository. +The buffer is displayed using `magit-display-buffer', which see. + +(fn BUFFER)" t) +(autoload 'magit-switch-to-repository-buffer "magit-extras" "\ +Switch to a Magit buffer belonging to the current Git repository. + +(fn BUFFER)" t) +(autoload 'magit-switch-to-repository-buffer-other-window "magit-extras" "\ +Switch to a Magit buffer belonging to the current Git repository. + +(fn BUFFER)" t) +(autoload 'magit-switch-to-repository-buffer-other-frame "magit-extras" "\ +Switch to a Magit buffer belonging to the current Git repository. + +(fn BUFFER)" t) +(autoload 'magit-abort-dwim "magit-extras" "\ +Abort current operation. +Depending on the context, this will abort a merge, a rebase, a +patch application, a cherry-pick, a revert, or a bisect." t) +(autoload 'magit-back-to-indentation "magit-extras" "\ +Move point to the first non-whitespace character on this line. +In Magit diffs, also skip over - and + at the beginning of the line." t) +(register-definition-prefixes "magit-extras" '("magit-")) + + +;;; Generated autoloads from magit-fetch.el + + (autoload 'magit-fetch "magit-fetch" nil t) + (autoload 'magit-fetch-from-pushremote "magit-fetch" nil t) + (autoload 'magit-fetch-from-upstream "magit-fetch" nil t) +(autoload 'magit-fetch-other "magit-fetch" "\ +Fetch from another repository. + +(fn REMOTE ARGS)" t) +(autoload 'magit-fetch-branch "magit-fetch" "\ +Fetch a BRANCH from a REMOTE. + +(fn REMOTE BRANCH ARGS)" t) +(autoload 'magit-fetch-refspec "magit-fetch" "\ +Fetch a REFSPEC from a REMOTE. + +(fn REMOTE REFSPEC ARGS)" t) +(autoload 'magit-fetch-all "magit-fetch" "\ +Fetch from all remotes. + +(fn ARGS)" t) +(autoload 'magit-fetch-all-prune "magit-fetch" "\ +Fetch from all remotes, and prune. +Prune remote tracking branches for branches that have been +removed on the respective remote." t) +(autoload 'magit-fetch-all-no-prune "magit-fetch" "\ +Fetch from all remotes." t) + (autoload 'magit-fetch-modules "magit-fetch" nil t) +(register-definition-prefixes "magit-fetch" '("magit-")) + + +;;; Generated autoloads from magit-files.el + +(autoload 'magit-find-file "magit-files" "\ +View FILE from REV. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go +to the line and column corresponding to that location. + +(fn REV FILE)" t) +(autoload 'magit-find-file-other-window "magit-files" "\ +View FILE from REV, in another window. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location. + +(fn REV FILE)" t) +(autoload 'magit-find-file-other-frame "magit-files" "\ +View FILE from REV, in another frame. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location. + +(fn REV FILE)" t) + (autoload 'magit-file-dispatch "magit" nil t) +(autoload 'magit-blob-visit-file "magit-files" "\ +View the file from the worktree corresponding to the current blob. +When visiting a blob or the version from the index, then go to +the same location in the respective file in the working tree." t) +(autoload 'magit-file-stage "magit-files" "\ +Stage all changes to the file being visited in the current buffer." t) +(autoload 'magit-file-unstage "magit-files" "\ +Unstage all changes to the file being visited in the current buffer." t) +(autoload 'magit-file-untrack "magit-files" "\ +Untrack the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +staged as well as unstaged changes. + +(fn FILES &optional FORCE)" t) +(autoload 'magit-file-rename "magit-files" "\ +Rename or move FILE to NEWNAME. +NEWNAME may be a file or directory name. If FILE isn't tracked in +Git, fallback to using `rename-file'. + +(fn FILE NEWNAME)" t) +(autoload 'magit-file-delete "magit-files" "\ +Delete the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +uncommitted changes. When the files aren't being tracked in +Git, then fallback to using `delete-file'. + +(fn FILES &optional FORCE)" t) +(autoload 'magit-file-checkout "magit-files" "\ +Checkout FILE from REV. + +(fn REV FILE)" t) +(register-definition-prefixes "magit-files" '("lsp" "magit-")) + + +;;; Generated autoloads from magit-git.el + +(register-definition-prefixes "magit-git" '("magit-")) + + +;;; Generated autoloads from magit-gitignore.el + + (autoload 'magit-gitignore "magit-gitignore" nil t) +(autoload 'magit-gitignore-in-topdir "magit-gitignore" "\ +Add the Git ignore RULE to the top-level \".gitignore\" file. +Since this file is tracked, it is shared with other clones of the +repository. Also stage the file. + +(fn RULE)" t) +(autoload 'magit-gitignore-in-subdir "magit-gitignore" "\ +Add the Git ignore RULE to a \".gitignore\" file in DIRECTORY. +Prompt the user for a directory and add the rule to the +\".gitignore\" file in that directory. Since such files are +tracked, they are shared with other clones of the repository. +Also stage the file. + +(fn RULE DIRECTORY)" t) +(autoload 'magit-gitignore-in-gitdir "magit-gitignore" "\ +Add the Git ignore RULE to \"$GIT_DIR/info/exclude\". +Rules in that file only affects this clone of the repository. + +(fn RULE)" t) +(autoload 'magit-gitignore-on-system "magit-gitignore" "\ +Add the Git ignore RULE to the file specified by `core.excludesFile'. +Rules that are defined in that file affect all local repositories. + +(fn RULE)" t) +(autoload 'magit-skip-worktree "magit-gitignore" "\ +Call \"git update-index --skip-worktree -- FILE\". + +(fn FILE)" t) +(autoload 'magit-no-skip-worktree "magit-gitignore" "\ +Call \"git update-index --no-skip-worktree -- FILE\". + +(fn FILE)" t) +(autoload 'magit-assume-unchanged "magit-gitignore" "\ +Call \"git update-index --assume-unchanged -- FILE\". + +(fn FILE)" t) +(autoload 'magit-no-assume-unchanged "magit-gitignore" "\ +Call \"git update-index --no-assume-unchanged -- FILE\". + +(fn FILE)" t) +(register-definition-prefixes "magit-gitignore" '("magit-")) + + +;;; Generated autoloads from magit-log.el + + (autoload 'magit-log "magit-log" nil t) + (autoload 'magit-log-refresh "magit-log" nil t) + (autoload 'magit-log-current "magit-log" nil t) +(autoload 'magit-log-head "magit-log" "\ +Show log for `HEAD'. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-log-related "magit-log" "\ +Show log for the current branch, its upstream and its push target. +When the upstream is a local branch, then also show its own +upstream. When `HEAD' is detached, then show log for that, the +previously checked out branch and its upstream and push-target. + +(fn REVS &optional ARGS FILES)" t) +(autoload 'magit-log-other "magit-log" "\ +Show log for one or more revs read from the minibuffer. +The user can input any revision or revisions separated by a +space, or even ranges, but only branches and tags, and a +representation of the commit at point, are available as +completion candidates. + +(fn REVS &optional ARGS FILES)" t) +(autoload 'magit-log-branches "magit-log" "\ +Show log for all local branches and `HEAD'. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-log-matching-branches "magit-log" "\ +Show log for all branches matching PATTERN and `HEAD'. + +(fn PATTERN &optional ARGS FILES)" t) +(autoload 'magit-log-matching-tags "magit-log" "\ +Show log for all tags matching PATTERN and `HEAD'. + +(fn PATTERN &optional ARGS FILES)" t) +(autoload 'magit-log-all-branches "magit-log" "\ +Show log for all local and remote branches and `HEAD'. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-log-all "magit-log" "\ +Show log for all references and `HEAD'. + +(fn &optional ARGS FILES)" t) +(autoload 'magit-log-buffer-file "magit-log" "\ +Show log for the blob or file visited in the current buffer. +With a prefix argument or when `--follow' is an active log +argument, then follow renames. When the region is active, +restrict the log to the lines that the region touches. + +(fn &optional FOLLOW BEG END)" t) +(autoload 'magit-log-trace-definition "magit-log" "\ +Show log for the definition at point. + +(fn FILE FN REV)" t) +(autoload 'magit-log-merged "magit-log" "\ +Show log for the merge of COMMIT into BRANCH. + +More precisely, find merge commit M that brought COMMIT into +BRANCH, and show the log of the range \"M^1..M\". If COMMIT is +directly on BRANCH, then show approximately +`magit-log-merged-commit-count' surrounding commits instead. + +This command requires git-when-merged, which is available from +https://github.com/mhagger/git-when-merged. + +(fn COMMIT BRANCH &optional ARGS FILES)" t) +(autoload 'magit-log-move-to-parent "magit-log" "\ +Move to the Nth parent of the current commit. + +(fn &optional N)" t) + (autoload 'magit-shortlog "magit-log" nil t) +(autoload 'magit-shortlog-since "magit-log" "\ +Show a history summary for commits since REV. + +(fn REV ARGS)" t) +(autoload 'magit-shortlog-range "magit-log" "\ +Show a history summary for commit or range REV-OR-RANGE. + +(fn REV-OR-RANGE ARGS)" t) +(autoload 'magit-cherry "magit-log" "\ +Show commits in a branch that are not merged in the upstream branch. + +(fn HEAD UPSTREAM)" t) +(register-definition-prefixes "magit-log" '("magit-")) + + +;;; Generated autoloads from magit-margin.el + +(register-definition-prefixes "magit-margin" '("magit-")) + + +;;; Generated autoloads from magit-merge.el + + (autoload 'magit-merge "magit" nil t) +(autoload 'magit-merge-plain "magit-merge" "\ +Merge commit REV into the current branch; using default message. + +Unless there are conflicts or a prefix argument is used create a +merge commit using a generic commit message and without letting +the user inspect the result. With a prefix argument pretend the +merge failed to give the user the opportunity to inspect the +merge. + +(git merge --no-edit|--no-commit [ARGS] REV) + +(fn REV &optional ARGS NOCOMMIT)" t) +(autoload 'magit-merge-editmsg "magit-merge" "\ +Merge commit REV into the current branch; and edit message. +Perform the merge and prepare a commit message but let the user +edit it. + +(git merge --edit --no-ff [ARGS] REV) + +(fn REV &optional ARGS)" t) +(autoload 'magit-merge-nocommit "magit-merge" "\ +Merge commit REV into the current branch; pretending it failed. +Pretend the merge failed to give the user the opportunity to +inspect the merge and change the commit message. + +(git merge --no-commit --no-ff [ARGS] REV) + +(fn REV &optional ARGS)" t) +(autoload 'magit-merge-dissolve "magit-merge" "\ +Merge the current branch into BRANCH and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch. + +(fn BRANCH &optional ARGS)" t) +(autoload 'magit-merge-absorb "magit-merge" "\ +Merge BRANCH into the current branch and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch. + +(fn BRANCH &optional ARGS)" t) +(autoload 'magit-merge-squash "magit-merge" "\ +Squash commit REV into the current branch; don't create a commit. + +(git merge --squash REV) + +(fn REV)" t) +(autoload 'magit-merge-preview "magit-merge" "\ +Preview result of merging REV into the current branch. + +(fn REV)" t) +(autoload 'magit-merge-abort "magit-merge" "\ +Abort the current merge operation. + +(git merge --abort)" t) +(register-definition-prefixes "magit-merge" '("magit-")) + + +;;; Generated autoloads from magit-mode.el + +(autoload 'magit-info "magit-mode" "\ +Visit the Magit manual." t) +(register-definition-prefixes "magit-mode" '("magit-")) + + +;;; Generated autoloads from magit-notes.el + + (autoload 'magit-notes "magit" nil t) +(register-definition-prefixes "magit-notes" '("magit-notes-")) + + +;;; Generated autoloads from magit-patch.el + + (autoload 'magit-patch "magit-patch" nil t) + (autoload 'magit-patch-create "magit-patch" nil t) + (autoload 'magit-patch-apply "magit-patch" nil t) +(autoload 'magit-patch-save "magit-patch" "\ +Write current diff into patch FILE. + +What arguments are used to create the patch depends on the value +of `magit-patch-save-arguments' and whether a prefix argument is +used. + +If the value is the symbol `buffer', then use the same arguments +as the buffer. With a prefix argument use no arguments. + +If the value is a list beginning with the symbol `exclude', then +use the same arguments as the buffer except for those matched by +entries in the cdr of the list. The comparison is done using +`string-prefix-p'. With a prefix argument use the same arguments +as the buffer. + +If the value is a list of strings (including the empty list), +then use those arguments. With a prefix argument use the same +arguments as the buffer. + +Of course the arguments that are required to actually show the +same differences as those shown in the buffer are always used. + +(fn FILE &optional ARG)" t) +(autoload 'magit-request-pull "magit-patch" "\ +Request upstream to pull from your public repository. + +URL is the url of your publicly accessible repository. +START is a commit that already is in the upstream repository. +END is the last commit, usually a branch name, which upstream +is asked to pull. START has to be reachable from that commit. + +(fn URL START END)" t) +(register-definition-prefixes "magit-patch" '("magit-")) + + +;;; Generated autoloads from magit-process.el + +(register-definition-prefixes "magit-process" '("magit-")) + + +;;; Generated autoloads from magit-pull.el + + (autoload 'magit-pull "magit-pull" nil t) + (autoload 'magit-pull-from-pushremote "magit-pull" nil t) + (autoload 'magit-pull-from-upstream "magit-pull" nil t) +(autoload 'magit-pull-branch "magit-pull" "\ +Pull from a branch read in the minibuffer. + +(fn SOURCE ARGS)" t) +(register-definition-prefixes "magit-pull" '("magit-pull-")) + + +;;; Generated autoloads from magit-push.el + + (autoload 'magit-push "magit-push" nil t) + (autoload 'magit-push-current-to-pushremote "magit-push" nil t) + (autoload 'magit-push-current-to-upstream "magit-push" nil t) +(autoload 'magit-push-current "magit-push" "\ +Push the current branch to a branch read in the minibuffer. + +(fn TARGET ARGS)" t) +(autoload 'magit-push-other "magit-push" "\ +Push an arbitrary branch or commit somewhere. +Both the source and the target are read in the minibuffer. + +(fn SOURCE TARGET ARGS)" t) +(autoload 'magit-push-refspecs "magit-push" "\ +Push one or multiple REFSPECS to a REMOTE. +Both the REMOTE and the REFSPECS are read in the minibuffer. To +use multiple REFSPECS, separate them with commas. Completion is +only available for the part before the colon, or when no colon +is used. + +(fn REMOTE REFSPECS ARGS)" t) +(autoload 'magit-push-matching "magit-push" "\ +Push all matching branches to another repository. +If multiple remotes exist, then read one from the user. +If just one exists, use that without requiring confirmation. + +(fn REMOTE &optional ARGS)" t) +(autoload 'magit-push-tags "magit-push" "\ +Push all tags to another repository. +If only one remote exists, then push to that. Otherwise prompt +for a remote, offering the remote configured for the current +branch as default. + +(fn REMOTE &optional ARGS)" t) +(autoload 'magit-push-tag "magit-push" "\ +Push a tag to another repository. + +(fn TAG REMOTE &optional ARGS)" t) +(autoload 'magit-push-notes-ref "magit-push" "\ +Push a notes ref to another repository. + +(fn REF REMOTE &optional ARGS)" t) + (autoload 'magit-push-implicitly "magit-push" nil t) + (autoload 'magit-push-to-remote "magit-push" nil t) +(register-definition-prefixes "magit-push" '("magit-")) + + +;;; Generated autoloads from magit-reflog.el + +(autoload 'magit-reflog-current "magit-reflog" "\ +Display the reflog of the current branch. +If `HEAD' is detached, then show the reflog for that instead." t) +(autoload 'magit-reflog-other "magit-reflog" "\ +Display the reflog of a branch or another ref. + +(fn REF)" t) +(autoload 'magit-reflog-head "magit-reflog" "\ +Display the `HEAD' reflog." t) +(register-definition-prefixes "magit-reflog" '("magit-reflog-")) + + +;;; Generated autoloads from magit-refs.el + + (autoload 'magit-show-refs "magit-refs" nil t) +(autoload 'magit-show-refs-head "magit-refs" "\ +List and compare references in a dedicated buffer. +Compared with `HEAD'. + +(fn &optional ARGS)" t) +(autoload 'magit-show-refs-current "magit-refs" "\ +List and compare references in a dedicated buffer. +Compare with the current branch or `HEAD' if it is detached. + +(fn &optional ARGS)" t) +(autoload 'magit-show-refs-other "magit-refs" "\ +List and compare references in a dedicated buffer. +Compared with a branch read from the user. + +(fn &optional REF ARGS)" t) +(register-definition-prefixes "magit-refs" '("magit-")) + + +;;; Generated autoloads from magit-remote.el + + (autoload 'magit-remote "magit-remote" nil t) +(autoload 'magit-remote-add "magit-remote" "\ +Add a remote named REMOTE and fetch it. + +(fn REMOTE URL &optional ARGS)" t) +(autoload 'magit-remote-rename "magit-remote" "\ +Rename the remote named OLD to NEW. + +(fn OLD NEW)" t) +(autoload 'magit-remote-remove "magit-remote" "\ +Delete the remote named REMOTE. + +(fn REMOTE)" t) +(autoload 'magit-remote-prune "magit-remote" "\ +Remove stale remote-tracking branches for REMOTE. + +(fn REMOTE)" t) +(autoload 'magit-remote-prune-refspecs "magit-remote" "\ +Remove stale refspecs for REMOTE. + +A refspec is stale if there no longer exists at least one branch +on the remote that would be fetched due to that refspec. A stale +refspec is problematic because its existence causes Git to refuse +to fetch according to the remaining non-stale refspecs. + +If only stale refspecs remain, then offer to either delete the +remote or to replace the stale refspecs with the default refspec. + +Also remove the remote-tracking branches that were created due to +the now stale refspecs. Other stale branches are not removed. + +(fn REMOTE)" t) +(autoload 'magit-remote-set-head "magit-remote" "\ +Set the local representation of REMOTE's default branch. +Query REMOTE and set the symbolic-ref refs/remotes//HEAD +accordingly. With a prefix argument query for the branch to be +used, which allows you to select an incorrect value if you fancy +doing that. + +(fn REMOTE &optional BRANCH)" t) +(autoload 'magit-remote-unset-head "magit-remote" "\ +Unset the local representation of REMOTE's default branch. +Delete the symbolic-ref \"refs/remotes//HEAD\". + +(fn REMOTE)" t) + (autoload 'magit-update-default-branch "magit-remote" nil t) +(autoload 'magit-remote-unshallow "magit-remote" "\ +Convert a shallow remote into a full one. +If only a single refspec is set and it does not contain a +wildcard, then also offer to replace it with the standard +refspec. + +(fn REMOTE)" t) + (autoload 'magit-remote-configure "magit-remote" nil t) +(register-definition-prefixes "magit-remote" '("magit-")) + + +;;; Generated autoloads from magit-repos.el + +(autoload 'magit-list-repositories "magit-repos" "\ +Display a list of repositories. + +Use the option `magit-repository-directories' to control which +repositories are displayed." t) +(register-definition-prefixes "magit-repos" '("magit-")) + + +;;; Generated autoloads from magit-reset.el + + (autoload 'magit-reset "magit" nil t) +(autoload 'magit-reset-mixed "magit-reset" "\ +Reset the `HEAD' and index to COMMIT, but not the working tree. + +(git reset --mixed COMMIT) + +(fn COMMIT)" t) +(autoload 'magit-reset-soft "magit-reset" "\ +Reset the `HEAD' to COMMIT, but not the index and working tree. + +(git reset --soft REVISION) + +(fn COMMIT)" t) +(autoload 'magit-reset-hard "magit-reset" "\ +Reset the `HEAD', index, and working tree to COMMIT. + +(git reset --hard REVISION) + +(fn COMMIT)" t) +(autoload 'magit-reset-keep "magit-reset" "\ +Reset the `HEAD' and index to COMMIT, while keeping uncommitted changes. + +(git reset --keep REVISION) + +(fn COMMIT)" t) +(autoload 'magit-reset-index "magit-reset" "\ +Reset the index to COMMIT. +Keep the `HEAD' and working tree as-is, so if COMMIT refers to the +head this effectively unstages all changes. + +(git reset COMMIT .) + +(fn COMMIT)" t) +(autoload 'magit-reset-worktree "magit-reset" "\ +Reset the worktree to COMMIT. +Keep the `HEAD' and index as-is. + +(fn COMMIT)" t) +(autoload 'magit-reset-quickly "magit-reset" "\ +Reset the `HEAD' and index to COMMIT, and possibly the working tree. +With a prefix argument reset the working tree otherwise don't. + +(git reset --mixed|--hard COMMIT) + +(fn COMMIT &optional HARD)" t) +(register-definition-prefixes "magit-reset" '("magit-reset-")) + + +;;; Generated autoloads from magit-sequence.el + +(autoload 'magit-sequencer-continue "magit-sequence" "\ +Resume the current cherry-pick or revert sequence." t) +(autoload 'magit-sequencer-skip "magit-sequence" "\ +Skip the stopped at commit during a cherry-pick or revert sequence." t) +(autoload 'magit-sequencer-abort "magit-sequence" "\ +Abort the current cherry-pick or revert sequence. +This discards all changes made since the sequence started." t) + (autoload 'magit-cherry-pick "magit-sequence" nil t) +(autoload 'magit-cherry-copy "magit-sequence" "\ +Copy COMMITS from another branch onto the current branch. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then pick all of them, +without prompting. + +(fn COMMITS &optional ARGS)" t) +(autoload 'magit-cherry-apply "magit-sequence" "\ +Apply the changes in COMMITS but do not commit them. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then apply all of them, +without prompting. + +(fn COMMITS &optional ARGS)" t) +(autoload 'magit-cherry-harvest "magit-sequence" "\ +Move COMMITS from another BRANCH onto the current branch. +Remove the COMMITS from BRANCH and stay on the current branch. +If a conflict occurs, then you have to fix that and finish the +process manually. + +(fn COMMITS BRANCH &optional ARGS)" t) +(autoload 'magit-cherry-donate "magit-sequence" "\ +Move COMMITS from the current branch onto another existing BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually. `HEAD' is allowed to be detached initially. + +(fn COMMITS BRANCH &optional ARGS)" t) +(autoload 'magit-cherry-spinout "magit-sequence" "\ +Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually. + +(fn COMMITS BRANCH START-POINT &optional ARGS)" t) +(autoload 'magit-cherry-spinoff "magit-sequence" "\ +Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and checkout BRANCH. +If a conflict occurs, then you have to fix that and finish +the process manually. + +(fn COMMITS BRANCH START-POINT &optional ARGS)" t) + (autoload 'magit-revert "magit-sequence" nil t) +(autoload 'magit-revert-and-commit "magit-sequence" "\ +Revert COMMIT by creating a new commit. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting. + +(fn COMMIT &optional ARGS)" t) +(autoload 'magit-revert-no-commit "magit-sequence" "\ +Revert COMMIT by applying it in reverse to the worktree. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting. + +(fn COMMIT &optional ARGS)" t) + (autoload 'magit-am "magit-sequence" nil t) +(autoload 'magit-am-apply-patches "magit-sequence" "\ +Apply the patches FILES. + +(fn &optional FILES ARGS)" t) +(autoload 'magit-am-apply-maildir "magit-sequence" "\ +Apply the patches from MAILDIR. + +(fn &optional MAILDIR ARGS)" t) +(autoload 'magit-am-continue "magit-sequence" "\ +Resume the current patch applying sequence." t) +(autoload 'magit-am-skip "magit-sequence" "\ +Skip the stopped at patch during a patch applying sequence." t) +(autoload 'magit-am-abort "magit-sequence" "\ +Abort the current patch applying sequence. +This discards all changes made since the sequence started." t) + (autoload 'magit-rebase "magit-sequence" nil t) + (autoload 'magit-rebase-onto-pushremote "magit-sequence" nil t) + (autoload 'magit-rebase-onto-upstream "magit-sequence" nil t) +(autoload 'magit-rebase-branch "magit-sequence" "\ +Rebase the current branch onto a branch read in the minibuffer. +All commits that are reachable from `HEAD' but not from the +selected branch TARGET are being rebased. + +(fn TARGET ARGS)" t) +(autoload 'magit-rebase-subset "magit-sequence" "\ +Rebase a subset of the current branch's history onto a new base. +Rebase commits from START to `HEAD' onto NEWBASE. +START has to be selected from a list of recent commits. + +(fn NEWBASE START ARGS)" t) +(autoload 'magit-rebase-interactive "magit-sequence" "\ +Start an interactive rebase sequence. + +(fn COMMIT ARGS)" t) +(autoload 'magit-rebase-autosquash "magit-sequence" "\ +Combine squash and fixup commits with their intended targets. +By default only squash into commits that are not reachable from +the upstream branch. If no upstream is configured or with a prefix +argument, prompt for the first commit to potentially squash into. + +(fn SELECT ARGS)" t) +(autoload 'magit-rebase-edit-commit "magit-sequence" "\ +Edit a single older commit using rebase. + +(fn COMMIT ARGS)" t) +(autoload 'magit-rebase-reword-commit "magit-sequence" "\ +Reword a single older commit using rebase. + +(fn COMMIT ARGS)" t) +(autoload 'magit-rebase-remove-commit "magit-sequence" "\ +Remove a single older commit using rebase. + +(fn COMMIT ARGS)" t) +(autoload 'magit-rebase-continue "magit-sequence" "\ +Restart the current rebasing operation. +In some cases this pops up a commit message buffer for you do +edit. With a prefix argument the old message is reused as-is. + +(fn &optional NOEDIT)" t) +(autoload 'magit-rebase-skip "magit-sequence" "\ +Skip the current commit and restart the current rebase operation." t) +(autoload 'magit-rebase-edit "magit-sequence" "\ +Edit the todo list of the current rebase operation." t) +(autoload 'magit-rebase-abort "magit-sequence" "\ +Abort the current rebase operation, restoring the original branch." t) +(register-definition-prefixes "magit-sequence" '("magit-")) + + +;;; Generated autoloads from magit-sparse-checkout.el + + (autoload 'magit-sparse-checkout "magit-sparse-checkout" nil t) +(autoload 'magit-sparse-checkout-enable "magit-sparse-checkout" "\ +Convert the working tree to a sparse checkout. + +(fn &optional ARGS)" t) +(autoload 'magit-sparse-checkout-set "magit-sparse-checkout" "\ +Restrict working tree to DIRECTORIES. +To extend rather than override the currently configured +directories, call `magit-sparse-checkout-add' instead. + +(fn DIRECTORIES)" t) +(autoload 'magit-sparse-checkout-add "magit-sparse-checkout" "\ +Add DIRECTORIES to the working tree. +To override rather than extend the currently configured +directories, call `magit-sparse-checkout-set' instead. + +(fn DIRECTORIES)" t) +(autoload 'magit-sparse-checkout-reapply "magit-sparse-checkout" "\ +Reapply the sparse checkout rules to the working tree. +Some operations such as merging or rebasing may need to check out +files that aren't included in the sparse checkout. Call this +command to reset to the sparse checkout state." t) +(autoload 'magit-sparse-checkout-disable "magit-sparse-checkout" "\ +Convert sparse checkout to full checkout. +Note that disabling the sparse checkout does not clear the +configured directories. Call `magit-sparse-checkout-enable' to +restore the previous sparse checkout." t) +(register-definition-prefixes "magit-sparse-checkout" '("magit-sparse-checkout-")) + + +;;; Generated autoloads from magit-stash.el + + (autoload 'magit-stash "magit-stash" nil t) +(autoload 'magit-stash-both "magit-stash" "\ +Create a stash of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +(fn MESSAGE &optional INCLUDE-UNTRACKED)" t) +(autoload 'magit-stash-index "magit-stash" "\ +Create a stash of the index only. +Unstaged and untracked changes are not stashed. The stashed +changes are applied in reverse to both the index and the +worktree. This command can fail when the worktree is not clean. +Applying the resulting stash has the inverse effect. + +(fn MESSAGE)" t) +(autoload 'magit-stash-worktree "magit-stash" "\ +Create a stash of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +(fn MESSAGE &optional INCLUDE-UNTRACKED)" t) +(autoload 'magit-stash-keep-index "magit-stash" "\ +Create a stash of the index and working tree, keeping index intact. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +(fn MESSAGE &optional INCLUDE-UNTRACKED)" t) +(autoload 'magit-snapshot-both "magit-stash" "\ +Create a snapshot of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +(fn &optional INCLUDE-UNTRACKED)" t) +(autoload 'magit-snapshot-index "magit-stash" "\ +Create a snapshot of the index only. +Unstaged and untracked changes are not stashed." t) +(autoload 'magit-snapshot-worktree "magit-stash" "\ +Create a snapshot of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'. + +(fn &optional INCLUDE-UNTRACKED)" t) + (autoload 'magit-stash-push "magit-stash" nil t) +(autoload 'magit-stash-apply "magit-stash" "\ +Apply a stash to the working tree. + +When using a Git release before v2.38.0, simply run \"git stash +apply\" or with a prefix argument \"git stash apply --index\". + +When using Git v2.38.0 or later, behave more intelligently: + +First try \"git stash apply --index\", which tries to preserve the +index stored in the stash, if any. This may fail because applying +the stash could result in conflicts and those have to be stored in +the index, making it impossible to also store the stash's index +there. + +If \"git stash\" fails, then potentially fall back to using \"git +apply\". If the stash does not touch any unstaged files, then pass +\"--3way\" to that command. Otherwise ask the user whether to use +that argument or \"--reject\". Customize `magit-no-confirm' if you +want to fall back to using \"--3way\", without being prompted. + +(fn STASH)" t) +(autoload 'magit-stash-pop "magit-stash" "\ +Apply a stash to the working tree, on success remove it from stash list. + +When using a Git release before v2.38.0, simply run \"git stash +pop\" or with a prefix argument \"git stash pop --index\". + +When using Git v2.38.0 or later, behave more intelligently: + +First try \"git stash apply --index\", which tries to preserve the +index stored in the stash, if any. This may fail because applying +the stash could result in conflicts and those have to be stored in +the index, making it impossible to also store the stash's index +there. + +If \"git stash\" fails, then potentially fall back to using \"git +apply\". If the stash does not touch any unstaged files, then pass +\"--3way\" to that command. Otherwise ask the user whether to use +that argument or \"--reject\". Customize `magit-no-confirm' if you +want to fall back to using \"--3way\", without being prompted. + +(fn STASH)" t) +(autoload 'magit-stash-drop "magit-stash" "\ +Remove a stash from the stash list. +When the region is active offer to drop all contained stashes. + +(fn STASH)" t) +(autoload 'magit-stash-clear "magit-stash" "\ +Remove all stashes saved in REF's reflog by deleting REF. + +(fn REF)" t) +(autoload 'magit-stash-branch "magit-stash" "\ +Create and checkout a new BRANCH from an existing STASH. +The new branch starts at the commit that was current when the +stash was created. If the stash applies cleanly, then drop it. + +(fn STASH BRANCH)" t) +(autoload 'magit-stash-branch-here "magit-stash" "\ +Create and checkout a new BRANCH from an existing STASH. +Use the current branch or `HEAD' as the starting-point of BRANCH. +Then apply STASH, dropping it if it applies cleanly. + +(fn STASH BRANCH)" t) +(autoload 'magit-stash-format-patch "magit-stash" "\ +Create a patch from STASH. + +(fn STASH)" t) +(autoload 'magit-stash-list "magit-stash" "\ +List all stashes in a buffer." t) +(autoload 'magit-stash-show "magit-stash" "\ +Show all diffs of a stash in a buffer. + +(fn STASH &optional ARGS FILES)" t) +(register-definition-prefixes "magit-stash" '("magit-")) + + +;;; Generated autoloads from magit-status.el + +(autoload 'magit-init "magit-status" "\ +Initialize a Git repository, then show its status. + +If the directory is below an existing repository, then the user +has to confirm that a new one should be created inside. If the +directory is the root of the existing repository, then the user +has to confirm that it should be reinitialized. + +Non-interactively DIRECTORY is (re-)initialized unconditionally. + +(fn DIRECTORY)" t) +(autoload 'magit-status "magit-status" "\ +Show the status of the current Git repository in a buffer. + +If the current directory isn't located within a Git repository, +then prompt for an existing repository or an arbitrary directory, +depending on option `magit-repository-directories', and show the +status of the selected repository instead. + +* If that option specifies any existing repositories, then offer + those for completion and show the status buffer for the + selected one. + +* Otherwise read an arbitrary directory using regular file-name + completion. If the selected directory is the top-level of an + existing working tree, then show the status buffer for that. + +* Otherwise offer to initialize the selected directory as a new + repository. After creating the repository show its status + buffer. + +These fallback behaviors can also be forced using one or more +prefix arguments: + +* With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) read an arbitrary directory and act on + it as described above. The same could be accomplished using + the command `magit-init'. + +* With a single prefix argument read an existing repository, or + if none can be found based on `magit-repository-directories', + then fall back to the same behavior as with two prefix + arguments. + +(fn &optional DIRECTORY CACHE)" t) +(defalias 'magit #'magit-status "\ +Begin using Magit. + +This alias for `magit-status' exists for better discoverability. + +Instead of invoking this alias for `magit-status' using +\"M-x magit RET\", you should bind a key to `magit-status' +and read the info node `(magit)Getting Started', which +also contains other useful hints.") +(autoload 'magit-status-here "magit-status" "\ +Like `magit-status' but with non-nil `magit-status-goto-file-position'." t) +(autoload 'magit-status-quick "magit-status" "\ +Show the status of the current Git repository, maybe without refreshing. + +If the status buffer of the current Git repository exists but +isn't being displayed in the selected frame, then display it +without refreshing it. + +If the status buffer is being displayed in the selected frame, +then also refresh it. + +Prefix arguments have the same meaning as for `magit-status', +and additionally cause the buffer to be refresh. + +To use this function instead of `magit-status', add this to your +init file: (global-set-key (kbd \"C-x g\") \\='magit-status-quick)." t) +(autoload 'magit-status-setup-buffer "magit-status" "\ + + +(fn &optional DIRECTORY)") +(register-definition-prefixes "magit-status" '("magit-")) + + +;;; Generated autoloads from magit-submodule.el + + (autoload 'magit-submodule "magit-submodule" nil t) + (autoload 'magit-submodule-add "magit-submodule" nil t) +(autoload 'magit-submodule-read-name-for-path "magit-submodule" "\ + + +(fn PATH &optional PREFER-SHORT)") + (autoload 'magit-submodule-register "magit-submodule" nil t) + (autoload 'magit-submodule-populate "magit-submodule" nil t) + (autoload 'magit-submodule-update "magit-submodule" nil t) + (autoload 'magit-submodule-synchronize "magit-submodule" nil t) + (autoload 'magit-submodule-unpopulate "magit-submodule" nil t) +(autoload 'magit-submodule-remove "magit-submodule" "\ +Unregister MODULES and remove their working directories. + +For safety reasons, do not remove the gitdirs and if a module has +uncommitted changes, then do not remove it at all. If a module's +gitdir is located inside the working directory, then move it into +the gitdir of the superproject first. + +With the \"--force\" argument offer to remove dirty working +directories and with a prefix argument offer to delete gitdirs. +Both actions are very dangerous and have to be confirmed. There +are additional safety precautions in place, so you might be able +to recover from making a mistake here, but don't count on it. + +(fn MODULES ARGS TRASH-GITDIRS)" t) +(autoload 'magit-insert-modules "magit-submodule" "\ +Insert submodule sections. +Hook `magit-module-sections-hook' controls which module sections +are inserted, and option `magit-module-sections-nested' controls +whether they are wrapped in an additional section.") +(autoload 'magit-insert-modules-overview "magit-submodule" "\ +Insert sections for all modules. +For each section insert the path and the output of `git describe --tags', +or, failing that, the abbreviated HEAD commit hash.") +(autoload 'magit-insert-modules-unpulled-from-upstream "magit-submodule" "\ +Insert sections for modules that haven't been pulled from the upstream. +These sections can be expanded to show the respective commits.") +(autoload 'magit-insert-modules-unpulled-from-pushremote "magit-submodule" "\ +Insert sections for modules that haven't been pulled from the push-remote. +These sections can be expanded to show the respective commits.") +(autoload 'magit-insert-modules-unpushed-to-upstream "magit-submodule" "\ +Insert sections for modules that haven't been pushed to the upstream. +These sections can be expanded to show the respective commits.") +(autoload 'magit-insert-modules-unpushed-to-pushremote "magit-submodule" "\ +Insert sections for modules that haven't been pushed to the push-remote. +These sections can be expanded to show the respective commits.") +(autoload 'magit-list-submodules "magit-submodule" "\ +Display a list of the current repository's populated submodules." t) +(register-definition-prefixes "magit-submodule" '("magit-")) + + +;;; Generated autoloads from magit-subtree.el + + (autoload 'magit-subtree "magit-subtree" nil t) + (autoload 'magit-subtree-import "magit-subtree" nil t) + (autoload 'magit-subtree-export "magit-subtree" nil t) +(autoload 'magit-subtree-add "magit-subtree" "\ +Add REF from REPOSITORY as a new subtree at PREFIX. + +(fn PREFIX REPOSITORY REF ARGS)" t) +(autoload 'magit-subtree-add-commit "magit-subtree" "\ +Add COMMIT as a new subtree at PREFIX. + +(fn PREFIX COMMIT ARGS)" t) +(autoload 'magit-subtree-merge "magit-subtree" "\ +Merge COMMIT into the PREFIX subtree. + +(fn PREFIX COMMIT ARGS)" t) +(autoload 'magit-subtree-pull "magit-subtree" "\ +Pull REF from REPOSITORY into the PREFIX subtree. + +(fn PREFIX REPOSITORY REF ARGS)" t) +(autoload 'magit-subtree-push "magit-subtree" "\ +Extract the history of the subtree PREFIX and push it to REF on REPOSITORY. + +(fn PREFIX REPOSITORY REF ARGS)" t) +(autoload 'magit-subtree-split "magit-subtree" "\ +Extract the history of the subtree PREFIX. + +(fn PREFIX COMMIT ARGS)" t) +(register-definition-prefixes "magit-subtree" '("magit-")) + + +;;; Generated autoloads from magit-tag.el + + (autoload 'magit-tag "magit" nil t) +(autoload 'magit-tag-create "magit-tag" "\ +Create a new tag with the given NAME at REV. +With a prefix argument annotate the tag. + +(git tag [--annotate] NAME REV) + +(fn NAME REV &optional ARGS)" t) +(autoload 'magit-tag-delete "magit-tag" "\ +Delete one or more tags. +If the region marks multiple tags (and nothing else), then offer +to delete those, otherwise prompt for a single tag to be deleted, +defaulting to the tag at point. + +(git tag -d TAGS) + +(fn TAGS)" t) +(autoload 'magit-tag-prune "magit-tag" "\ +Offer to delete tags missing locally from REMOTE, and vice versa. + +(fn TAGS REMOTE-TAGS REMOTE)" t) +(autoload 'magit-tag-release "magit-tag" "\ +Create a release tag for `HEAD'. + +Assume that release tags match `magit-release-tag-regexp'. + +If `HEAD's message matches `magit-release-commit-regexp', then +base the tag on the version string specified by that. Otherwise +prompt for the name of the new tag using the highest existing +tag as initial input and leaving it to the user to increment the +desired part of the version string. + +When creating an annotated tag, prepare a message based on the message +of the highest existing tag, provided that contains the corresponding +version string, and substituting the new version string for that. If +that is not the case, propose a message using a reasonable format. + +(fn TAG MSG &optional ARGS)" t) +(register-definition-prefixes "magit-tag" '("magit-")) + + +;;; Generated autoloads from magit-transient.el + +(register-definition-prefixes "magit-transient" '("magit-")) + + +;;; Generated autoloads from magit-wip.el + +(defvar magit-wip-mode nil "\ +Non-nil if Magit-Wip mode is enabled. +See the `magit-wip-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-wip-mode'.") +(custom-autoload 'magit-wip-mode "magit-wip" nil) +(autoload 'magit-wip-mode "magit-wip" "\ +Save uncommitted changes to work-in-progress refs. + +Whenever appropriate (i.e., when dataloss would be a possibility +otherwise) this mode causes uncommitted changes to be committed +to dedicated work-in-progress refs. + +For historic reasons this mode is implemented on top of four +other `magit-wip-*' modes, which can also be used individually, +if you want finer control over when the wip refs are updated; +but that is discouraged. + +This is a global minor mode. If called interactively, toggle the +`Magit-Wip mode' mode. If the prefix argument is positive, enable the +mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='magit-wip-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(put 'magit-wip-after-save-mode 'globalized-minor-mode t) +(defvar magit-wip-after-save-mode nil "\ +Non-nil if Magit-Wip-After-Save mode is enabled. +See the `magit-wip-after-save-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-wip-after-save-mode'.") +(custom-autoload 'magit-wip-after-save-mode "magit-wip" nil) +(autoload 'magit-wip-after-save-mode "magit-wip" "\ +Toggle Magit-Wip-After-Save-Local mode in all buffers. +With prefix ARG, enable Magit-Wip-After-Save mode if ARG is positive; +otherwise, disable it. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +Magit-Wip-After-Save-Local mode is enabled in all buffers where +`magit-wip-after-save-local-mode-turn-on' would do it. + +See `magit-wip-after-save-local-mode' for more information on +Magit-Wip-After-Save-Local mode. + +(fn &optional ARG)" t) +(defvar magit-wip-after-apply-mode nil "\ +Non-nil if Magit-Wip-After-Apply mode is enabled. +See the `magit-wip-after-apply-mode' command +for a description of this minor mode.") +(custom-autoload 'magit-wip-after-apply-mode "magit-wip" nil) +(autoload 'magit-wip-after-apply-mode "magit-wip" "\ +Commit to work-in-progress refs. + +After applying a change using any \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected files to the current wip refs. For each branch there +may be two wip refs; one contains snapshots of the files as found +in the worktree and the other contains snapshots of the entries +in the index. + +This is a global minor mode. If called interactively, toggle the +`Magit-Wip-After-Apply mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='magit-wip-after-apply-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(defvar magit-wip-before-change-mode nil "\ +Non-nil if Magit-Wip-Before-Change mode is enabled. +See the `magit-wip-before-change-mode' command +for a description of this minor mode.") +(custom-autoload 'magit-wip-before-change-mode "magit-wip" nil) +(autoload 'magit-wip-before-change-mode "magit-wip" "\ +Commit to work-in-progress refs before certain destructive changes. + +Before invoking a revert command or an \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected tracked files to the current wip refs. For each branch +there may be two wip refs; one contains snapshots of the files +as found in the worktree and the other contains snapshots of the +entries in the index. + +Only changes to files which could potentially be affected by the +command which is about to be called are committed. + +This is a global minor mode. If called interactively, toggle the +`Magit-Wip-Before-Change mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='magit-wip-before-change-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(autoload 'magit-wip-commit-initial-backup "magit-wip" "\ +Before saving, commit current file to a worktree wip ref. + +The user has to add this function to `before-save-hook'. + +Commit the current state of the visited file before saving the +current buffer to that file. This backs up the same version of +the file as `backup-buffer' would, but stores the backup in the +worktree wip ref, which is also used by the various Magit Wip +modes, instead of in a backup file as `backup-buffer' would. + +This function ignores the variables that affect `backup-buffer' +and can be used along-side that function, which is recommended +because this function only backs up files that are tracked in +a Git repository.") +(register-definition-prefixes "magit-wip" '("magit-")) + + +;;; Generated autoloads from magit-worktree.el + + (autoload 'magit-worktree "magit-worktree" nil t) +(autoload 'magit-worktree-checkout "magit-worktree" "\ +Checkout BRANCH in a new worktree at PATH. + +(fn PATH BRANCH)" t) +(autoload 'magit-worktree-branch "magit-worktree" "\ +Create a new BRANCH and check it out in a new worktree at PATH. + +(fn PATH BRANCH START-POINT)" t) +(autoload 'magit-worktree-move "magit-worktree" "\ +Move WORKTREE to PATH. + +(fn WORKTREE PATH)" t) +(register-definition-prefixes "magit-worktree" '("magit-")) + +;;; End of scraped data + +(provide 'magit-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; magit-autoloads.el ends here blob - /dev/null blob + 3579bf2ead0980f7552185f6e58c6bf6ddcbcbed (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-autorevert.el @@ -0,0 +1,271 @@ +;;; magit-autorevert.el --- Revert buffers when files in repository change -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for automatically reverting buffers +;; when visited files in the repository change. + +;; See (info "(magit)Automatic Reverting of File-Visiting Buffers"). + +;;; Code: + +(require 'magit-process) + +(require 'autorevert) + +;;; Options + +(defgroup magit-auto-revert nil + "Revert buffers when files in repository change." + :link '(custom-group-link auto-revert) + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'auto-revert + :group 'magit-essentials + :group 'magit-modes) + +(defcustom auto-revert-buffer-list-filter nil + "Filter that determines which buffers `auto-revert-buffers' reverts. + +This option is provided by Magit, which also advises +`auto-revert-buffers' to respect it. Magit users who do not turn +on the local mode `auto-revert-mode' themselves, are best served +by setting the value to `magit-auto-revert-repository-buffer-p'. + +However the default is nil, so as not to disturb users who do use +the local mode directly. If you experience delays when running +Magit commands, then you should consider using one of the +predicates provided by Magit - especially if you also use Tramp. + +Users who do turn on `auto-revert-mode' in buffers in which Magit +doesn't do that for them, should likely not use any filter. +Users who turn on `global-auto-revert-mode', do not have to worry +about this option, because it is disregarded if the global mode +is enabled." + :package-version '(magit . "2.4.2") + :group 'auto-revert + :group 'magit-auto-revert + :group 'magit-related + :type `(radio (const :tag "No filter" nil) + (function-item ,#'magit-auto-revert-buffer-p) + (function-item ,#'magit-auto-revert-repository-buffer-p) + function)) + +(defcustom magit-auto-revert-tracked-only t + "Whether `magit-auto-revert-mode' only reverts tracked files." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean + :set (lambda (var val) + (set var val) + (when (and (bound-and-true-p magit-auto-revert-mode) + (featurep 'magit-autorevert)) + (magit-auto-revert-mode -1) + (magit-auto-revert-mode)))) + +(defcustom magit-auto-revert-immediately t + "Whether Magit reverts buffers immediately. + +If this is non-nil and either `global-auto-revert-mode' or +`magit-auto-revert-mode' is enabled, then Magit immediately +reverts buffers by explicitly calling `auto-revert-buffers' +after running Git for side-effects. + +If `auto-revert-use-notify' is non-nil (and file notifications +are actually supported), then `magit-auto-revert-immediately' +does not have to be non-nil, because the reverts happen +immediately anyway. + +If `magit-auto-revert-immediately' and `auto-revert-use-notify' +are both nil, then reverts happen after `auto-revert-interval' +seconds of user inactivity. That is not desirable." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean) + +;;; Mode + +(defun magit-turn-on-auto-revert-mode-if-desired (&optional file) + (cond (file + (when-let ((buffer (find-buffer-visiting file))) + (with-current-buffer buffer + (magit-turn-on-auto-revert-mode-if-desired)))) + ((and (not auto-revert-mode) ; see #3014 + (not global-auto-revert-mode) ; see #3460 + buffer-file-name + (or auto-revert-remote-files ; see #5422 + (not (file-remote-p buffer-file-name))) + (file-readable-p buffer-file-name) + (compat-call executable-find (magit-git-executable) t) + (magit-toplevel) + (or (not magit-auto-revert-tracked-only) + (magit-file-tracked-p buffer-file-name))) + (auto-revert-mode 1)))) + +;;;###autoload +(define-globalized-minor-mode magit-auto-revert-mode auto-revert-mode + magit-turn-on-auto-revert-mode-if-desired + :package-version '(magit . "2.4.0") + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'magit-auto-revert + :group 'magit-essentials + ;; - When `global-auto-revert-mode' is enabled, then this mode is + ;; redundant. + ;; - In all other cases enable the mode because if buffers are not + ;; automatically reverted that would make many very common tasks + ;; much more cumbersome. + :init-value (not (or global-auto-revert-mode + noninteractive))) +;; - Unfortunately `:init-value t' only sets the value of the mode +;; variable but does not cause the mode function to be called. +;; - I don't think it works like this on purpose, but since one usually +;; should not enable global modes by default, it is understandable. +;; - If the user has set the variable `magit-auto-revert-mode' to nil +;; after loading magit (instead of doing so before loading magit or +;; by using the function), then we should still respect that setting. +;; - If the user enables `global-auto-revert-mode' after loading magit +;; and after `after-init-hook' has run, then `magit-auto-revert-mode' +;; remains enabled; and there is nothing we can do about it. +;; - However if the init file causes `magit-autorevert' to be loaded +;; and only later it enables `global-auto-revert-mode', then we can +;; and should leave `magit-auto-revert-mode' disabled. +(defun magit-auto-revert-mode--init-kludge () + "This is an internal kludge to be used on `after-init-hook'. +Do not use this function elsewhere, and don't remove it from +the `after-init-hook'. For more information see the comments +and code surrounding the definition of this function." + (if (or (not magit-auto-revert-mode) + (and global-auto-revert-mode (not after-init-time))) + (magit-auto-revert-mode -1) + (let ((start (current-time))) + (magit-message "Turning on magit-auto-revert-mode...") + (magit-auto-revert-mode 1) + (magit-message + "Turning on magit-auto-revert-mode...done%s" + (let ((elapsed (float-time (time-since start)))) + (if (> elapsed 0.2) + (format " (%.3fs, %s buffers checked)" elapsed + (length (buffer-list))) + "")))))) +(if after-init-time + ;; Since `after-init-hook' has already been + ;; run, turn the mode on or off right now. + (magit-auto-revert-mode--init-kludge) + ;; By the time the init file has been fully loaded the + ;; values of the relevant variables might have changed. + (add-hook 'after-init-hook #'magit-auto-revert-mode--init-kludge t)) + +(put 'magit-auto-revert-mode 'function-documentation + "Toggle Magit Auto Revert mode. +If called interactively, enable Magit Auto Revert mode if ARG is +positive, and disable it if ARG is zero or negative. If called +from Lisp, also enable the mode if ARG is omitted or nil, and +toggle it if ARG is `toggle'; disable the mode otherwise. + +Magit Auto Revert mode is a global minor mode that reverts +buffers associated with a file that is located inside a Git +repository when the file changes on disk. Use `auto-revert-mode' +to revert a particular buffer. Or use `global-auto-revert-mode' +to revert all file-visiting buffers, not just those that visit +a file located inside a Git repository. + +This global mode works by turning on the buffer-local mode +`auto-revert-mode' at the time a buffer is first created. The +local mode is turned on if the visited file is being tracked in +a Git repository at the time when the buffer is created. + +If `magit-auto-revert-tracked-only' is non-nil (the default), +then only tracked files are reverted. But if you stage a +previously untracked file using `magit-stage', then this mode +notices that. + +Unlike `global-auto-revert-mode', this mode never reverts any +buffers that are not visiting files. + +The behavior of this mode can be customized using the options +in the `autorevert' and `magit-autorevert' groups. + +This function calls the hook `magit-auto-revert-mode-hook'. + +Like nearly every mode, this mode should be enabled or disabled +by calling the respective mode function, the reason being that +changing the state of a mode involves more than merely toggling +a single switch, so setting the mode variable is not enough. +Also, you should not use `after-init-hook' to disable this mode.") + +(defun magit-auto-revert-buffers () + (when (and magit-auto-revert-immediately + (or global-auto-revert-mode + (and magit-auto-revert-mode auto-revert-buffer-list))) + (let ((auto-revert-buffer-list-filter + (or auto-revert-buffer-list-filter + #'magit-auto-revert-repository-buffer-p))) + (auto-revert-buffers)))) + +(defvar magit-auto-revert-toplevel nil) + +(defvar magit-auto-revert-counter 1 + "Incremented each time `auto-revert-buffers' is called.") + +(defun magit-auto-revert-buffer-p (buffer) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return t for any BUFFER." + (magit-auto-revert-repository-buffer-p buffer t)) + +(defun magit-auto-revert-repository-buffer-p (buffer &optional fallback) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return FALLBACK (which +defaults to nil) for any BUFFER." + ;; Call `magit-toplevel' just once per cycle. + (unless (and magit-auto-revert-toplevel + (= (cdr magit-auto-revert-toplevel) + magit-auto-revert-counter)) + (setq magit-auto-revert-toplevel + (cons (or (magit-toplevel) 'no-repo) + magit-auto-revert-counter))) + (let ((top (car magit-auto-revert-toplevel))) + (if (eq top 'no-repo) + fallback + (let ((dir (buffer-local-value 'default-directory buffer))) + (and (equal (file-remote-p dir) + (file-remote-p top)) + ;; ^ `tramp-handle-file-in-directory-p' lacks this optimization. + (file-in-directory-p dir top)))))) + +(define-advice auto-revert-buffers (:around (fn) buffer-list-filter) + (cl-incf magit-auto-revert-counter) + (if (or global-auto-revert-mode + (not auto-revert-buffer-list) + (not auto-revert-buffer-list-filter)) + (funcall fn) + (let ((auto-revert-buffer-list + (seq-filter auto-revert-buffer-list-filter + auto-revert-buffer-list))) + (funcall fn)) + (unless auto-revert-timer + (auto-revert-set-timer)))) + +;;; _ +(provide 'magit-autorevert) +;;; magit-autorevert.el ends here blob - /dev/null blob + 402454653a9a7ca9aef64fad31bfcc55279f8f21 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-base.el @@ -0,0 +1,1201 @@ +;;; magit-base.el --- Early birds -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;; This file contains code taken from GNU Emacs, which is +;; Copyright (C) 1976-2023 Free Software Foundation, Inc. + +;;; Commentary: + +;; This library defines utility functions, options and other things that +;; have to be available early on because they are used by several other +;; libraries, which cannot depend on one another, because that would lead +;; to circular dependencies. + +;;; Code: + +;; Also update EMACS_VERSION in "default.mk". +(defconst magit--minimal-emacs "27.1") +(defconst magit--minimal-git "2.25.0") + +(require 'cl-lib) +(require 'compat) +(require 'eieio) +(require 'llama) +(require 'subr-x) + +;; For older Emacs releases we depend on an updated `seq' release from +;; GNU ELPA, for `seq-keep'. Unfortunately something else may already +;; have required `seq', before `package' had a chance to put the more +;; recent version earlier on the `load-path'. +(when (and (featurep 'seq) + (not (fboundp 'seq-keep))) + (unload-feature 'seq 'force)) +(require 'seq) + +(require 'crm) + +(require 'magit-section) + +(eval-when-compile (require 'info)) +(declare-function Info-get-token "info" (pos start all &optional errorstring)) + +(eval-when-compile (require 'vc-git)) +(declare-function vc-git--run-command-string "vc-git" (file &rest args)) + +(eval-when-compile (require 'which-func)) +(declare-function which-function "which-func" ()) + +;;; Options + +(defcustom magit-completing-read-function #'magit-builtin-completing-read + "Function to be called when requesting input from the user. + +The default, `magit-builtin-completing-read', support third-party +completion frameworks, including `vertico-mode', `ivy-mode' and +`helm-mode'. + +However, if you would like to use Ivy or Helm completion with Magit but +not enable the respective modes globally, then customize this option to +use `ivy-completing-read' or `helm--completing-read-default'. + +If you still use `ido-mode', you'll likely need the `magit-ido' package." + :group 'magit-essentials + :type `(radio (function-item ,#'magit-builtin-completing-read) + (function-item ivy-completing-read) + (function-item helm--completing-read-default) + (function :tag "Other function"))) + +(defcustom magit-dwim-selection + ;; Do not function-quote to avoid circular dependencies. + '((magit-stash-apply nil t) + (magit-ediff-resolve-all nil t) + (magit-ediff-resolve-rest nil t) + (magit-stash-branch nil t) + (magit-stash-branch-here nil t) + (magit-stash-format-patch nil t) + (magit-stash-drop nil ask) + (magit-stash-pop nil ask)) + "When not to offer alternatives and ask for confirmation. + +Many commands by default ask the user to select from a list of +possible candidates. They do so even when there is a thing at +point that they can act on, which is then offered as the default. + +This option can be used to tell certain commands to use the thing +at point instead of asking the user to select a candidate to act +on, with or without confirmation. + +The value has the form ((COMMAND nil|PROMPT DEFAULT)...). + +- COMMAND is the command that should not prompt for a choice. + To have an effect, the command has to use the function + `magit-completing-read' or a utility function which in turn uses + that function. + +- If the command uses `magit-completing-read' multiple times, then + PROMPT can be used to only affect one of these uses. PROMPT, if + non-nil, is a regular expression that is used to match against + the PROMPT argument passed to `magit-completing-read'. + +- DEFAULT specifies how to use the default. If it is t, then + the DEFAULT argument passed to `magit-completing-read' is used + without confirmation. If it is `ask', then the user is given + a chance to abort. DEFAULT can also be nil, in which case the + entry has no effect." + :package-version '(magit . "2.12.0") + :group 'magit-commands + :type '(repeat + (list (symbol :tag "Command") ; It might not be fboundp yet. + (choice (const :tag "For all prompts" nil) + (regexp :tag "For prompts matching regexp")) + (choice (const :tag "Offer other choices" nil) + (const :tag "Require confirmation" ask) + (const :tag "Use default without confirmation" t))))) + +(defconst magit--confirm-actions + '((const discard) + (const reverse) + (const stage-all-changes) + (const unstage-all-changes) + (const delete) + (const trash) + (const resurrect) + (const untrack) + (const rename) + (const reset-bisect) + (const abort-cherry-pick) + (const abort-revert) + (const abort-rebase) + (const abort-merge) + (const merge-dirty) + (const delete-unmerged-branch) + (const delete-branch-on-remote) + (const delete-pr-remote) + (const drop-stashes) + (const set-and-push) + (const amend-published) + (const rebase-published) + (const edit-published) + (const remove-modules) + (const remove-dirty-modules) + (const trash-module-gitdirs) + (const stash-apply-3way) + (const kill-process) + (const safe-with-wip))) + +(defcustom magit-no-confirm '(set-and-push) + "A list of symbols for actions Magit should not confirm, or t. + +Many potentially dangerous commands by default ask the user for +confirmation. Each of the below symbols stands for an action +which, when invoked unintentionally or without being fully aware +of the consequences, could lead to tears. In many cases there +are several commands that perform variations of a certain action, +so we don't use the command names but more generic symbols. + +Applying changes: + + `discard' Discarding one or more changes (i.e., hunks or the + complete diff for a file) loses that change, obviously. + + `reverse' Reverting one or more changes can usually be undone + by reverting the reversion. + + `stage-all-changes', `unstage-all-changes' When there are both + staged and unstaged changes, then un-/staging everything would + destroy that distinction. Of course that also applies when + un-/staging a single change, but then less is lost and one does + that so often that having to confirm every time would be + unacceptable. + +Files: + + `delete' When a file that isn't yet tracked by Git is deleted + then it is completely lost, not just the last changes. Very + dangerous. + + `trash' Instead of deleting a file it can also be move to the + system trash. Obviously much less dangerous than deleting it. + + Also see option `magit-delete-by-moving-to-trash'. + + `resurrect' A deleted file can easily be resurrected by + \"deleting\" the deletion, which is done using the same command + that was used to delete the same file in the first place. + + `untrack' Untracking a file can be undone by tracking it again. + + `rename' Renaming a file can easily be undone. + +Sequences: + + `reset-bisect' Aborting (known to Git as \"resetting\") a + bisect operation loses all information collected so far. + + `abort-cherry-pick' Aborting a cherry-pick throws away all + conflict resolutions which has already been carried out by the + user. + + `abort-revert' Aborting a revert throws away all conflict + resolutions which has already been carried out by the user. + + `abort-rebase' Aborting a rebase throws away all already + modified commits, but it's possible to restore those from the + reflog. + + `abort-merge' Aborting a merge throws away all conflict + resolutions which has already been carried out by the user. + + `merge-dirty' Merging with a dirty worktree can make it hard to + go back to the state before the merge was initiated. + +References: + + `delete-unmerged-branch' Once a branch has been deleted it can + only be restored using low-level recovery tools provided by + Git. And even then the reflog is gone. The user always has + to confirm the deletion of a branch by accepting the default + choice (or selecting another branch), but when a branch has + not been merged yet, also make sure the user is aware of that. + + `delete-branch-on-remote' Deleting a \"remote branch\" may mean + deleting the (local) \"remote-tracking\" branch only, or also + removing it from the remote itself. The latter often makes more + sense because otherwise simply fetching from the remote would + restore the remote-tracking branch, but doing that can be + surprising and hard to recover from, so we ask. + + `delete-pr-remote' When deleting a branch that was created from + a pull-request and if no other branches still exist on that + remote, then `magit-branch-delete' offers to delete the remote + as well. This should be safe because it only happens if no + other refs exist in the remotes namespace, and you can recreate + the remote if necessary. + + `drop-stashes' Dropping a stash is dangerous because Git stores + stashes in the reflog. Once a stash is removed, there is no + going back without using low-level recovery tools provided by + Git. When a single stash is dropped, then the user always has + to confirm by accepting the default (or selecting another). + This action only concerns the deletion of multiple stashes at + once. + +Publishing: + + `set-and-push' When pushing to the upstream or the push-remote + and that isn't actually configured yet, then the user can first + set the target. If s/he confirms the default too quickly, then + s/he might end up pushing to the wrong branch and if the remote + repository is configured to disallow fixing such mistakes, then + that can be quite embarrassing and annoying. + +Edit published history: + + Without adding these symbols here, you will be warned before + editing commits that have already been pushed to one of the + branches listed in `magit-published-branches'. + + `amend-published' Affects most commands that amend to `HEAD'. + + `rebase-published' Affects commands that perform interactive + rebases. This includes commands from the commit popup that + modify a commit other than `HEAD', namely the various fixup + and squash variants. + + `edit-published' Affects the commands `magit-edit-line-commit' + and `magit-diff-edit-hunk-commit'. These two commands make + it quite easy to accidentally edit a published commit, so you + should think twice before configuring them not to ask for + confirmation. + + To disable confirmation completely, add all three symbols here + or set `magit-published-branches' to nil. + +Removing modules: + + `remove-modules' When you remove the working directory of a + module that does not contain uncommitted changes, then that is + safer than doing so when there are uncommitted changes and/or + when you also remove the gitdir. Still, you don't want to do + that by accident. + + `remove-dirty-modules' When you remove the working directory of + a module that contains uncommitted changes, then those changes + are gone for good. It is better to go to the module, inspect + these changes and only if appropriate discard them manually. + + `trash-module-gitdirs' When you remove the gitdir of a module, + then all unpushed changes are gone for good. It is very easy + to forget that you have some unfinished work on an unpublished + feature branch or even in a stash. + + Actually there are some safety precautions in place, that might + help you out if you make an unwise choice here, but don't count + on it. In case of emergency, stay calm and check the stash and + the `trash-directory' for traces of lost work. + +Various: + + `stash-apply-3way' When a stash cannot be applied using \"git + stash apply\", then Magit uses \"git apply\" instead, possibly + using the \"--3way\" argument, which isn't always perfectly + safe. See also `magit-stash-apply'. + + `kill-process' There seldom is a reason to kill a process. + +Global settings: + + Instead of adding all of the above symbols to the value of this + option you can also set it to the atom `t', which has the same + effect as adding all of the above symbols. Doing that most + certainly is a bad idea, especially because other symbols might + be added in the future. So even if you don't want to be asked + for confirmation for any of these actions, you are still better + of adding all of the respective symbols individually. + + When `magit-wip-before-change-mode' is enabled then these actions + can fairly easily be undone: `discard', `reverse', + `stage-all-changes', and `unstage-all-changes'. If and only if + this mode is enabled, then `safe-with-wip' has the same effect + as adding all of these symbols individually." + :package-version '(magit . "2.1.0") + :group 'magit-essentials + :group 'magit-commands + :type `(choice (const :tag "Always require confirmation" nil) + (const :tag "Never require confirmation" t) + (set :tag "Require confirmation except for" + ;; `remove-dirty-modules' and + ;; `trash-module-gitdirs' intentionally + ;; omitted. + ,@magit--confirm-actions))) + +(defcustom magit-slow-confirm '(drop-stashes) + "Whether to ask user \"y or n\" or \"yes or no\" questions. + +When this is nil, then `y-or-n-p' is used when the user has to +confirm a potentially destructive action. When this is t, then +`yes-or-no-p' is used instead. If this is a list of symbols +identifying actions, then `yes-or-no-p' is used for those, +`y-or-no-p' for all others. The list of actions is the same as +for `magit-no-confirm' (which see)." + :package-version '(magit . "2.9.0") + :group 'magit-miscellaneous + :type `(choice (const :tag "Always ask \"yes or no\" questions" t) + (const :tag "Always ask \"y or n\" questions" nil) + (set :tag "Ask \"yes or no\" questions only for" + ,@magit--confirm-actions))) + +(defcustom magit-no-message nil + "A list of messages Magit should not display. + +Magit displays most echo area messages using `message', but a few +are displayed using `magit-message' instead, which takes the same +arguments as the former, FORMAT-STRING and ARGS. `magit-message' +forgoes printing a message if any member of this list is a prefix +of the respective FORMAT-STRING. + +If Magit prints a message which causes you grief, then please +first investigate whether there is another option which can be +used to suppress it. If that is not the case, then ask the Magit +maintainers to start using `magit-message' instead of `message' +in that case. We are not proactively replacing all uses of +`message' with `magit-message', just in case someone *might* find +some of these messages useless. + +Messages which can currently be suppressed using this option are: +* \"Turning on magit-auto-revert-mode...\"" + :package-version '(magit . "2.8.0") + :group 'magit-miscellaneous + :type '(repeat string)) + +(defcustom magit-verbose-messages nil + "Whether to make certain prompts and messages more verbose. + +Occasionally a user suggests that a certain prompt or message +should be more verbose, but I would prefer to keep it as-is +because I don't think that the fact that that one user did not +understand the existing prompt/message means that a large number +of users would have the same difficulty, and that making it more +verbose would actually do a disservice to users who understand +the shorter prompt well enough. + +Going forward I will start offering both messages when I feel the +suggested longer message is reasonable enough, and the value of +this option decides which will be used. Note that changing the +value of this option affects all such messages and that I do not +intend to add an option per prompt." + :package-version '(magit . "4.0.0") + :group 'magit-miscellaneous + :type 'boolean) + +(defcustom magit-ellipsis + '((margin (?… . ">")) + (t (?… . "..."))) + "Characters or strings used to abbreviate text in some buffers. + +Each element has the form (WHERE (FANCY . UNIVERSAL)). + +FANCY is a single character or nil whereas UNIVERSAL is a string +of any length. The ellipsis produced by `magit--ellipsis' will +be FANCY if it's a non-nil character that can be displayed with +the available fonts, otherwise UNIVERSAL will be used. FANCY is +meant to be a rich character like a horizontal ellipsis symbol or +an emoji whereas UNIVERSAL something simpler available in a less +rich environment like the CLI. WHERE determines the use-case for +the ellipsis definition. Currently the only acceptable values +for WHERE are `margin' or t (representing the default). + +Whether collapsed sections are indicated using ellipsis is +controlled by `magit-section-visibility-indicator'." + :package-version '(magit . "4.0.0") + :group 'magit-miscellaneous + :type '(repeat (list (symbol :tag "Where") + (cons (choice :tag "Fancy" character (const nil)) + (string :tag "Universal"))))) + +(defcustom magit-update-other-window-delay 0.2 + "Delay before automatically updating the other window. + +When moving around in certain buffers, then certain other +buffers, which are being displayed in another window, may +optionally be updated to display information about the +section at point. + +When holding down a key to move by more than just one section, +then that would update that buffer for each section on the way. +To prevent that, updating the revision buffer is delayed, and +this option controls for how long. For optimal experience you +might have to adjust this delay and/or the keyboard repeat rate +and delay of your graphical environment or operating system." + :package-version '(magit . "2.3.0") + :group 'magit-miscellaneous + :type 'number) + +(defcustom magit-view-git-manual-method 'info + "How links to Git documentation are followed from Magit's Info manuals. + +`info' Follow the link to the node in the `gitman' Info manual + as usual. Unfortunately that manual is not installed by + default on some platforms, and when it is then the nodes + look worse than the actual manpages. + +`man' View the respective man-page using the `man' package. + +`woman' View the respective man-page using the `woman' package." + :package-version '(magit . "2.9.0") + :group 'magit-miscellaneous + :type '(choice (const :tag "View info manual" info) + (const :tag "View manpage using `man'" man) + (const :tag "View manpage using `woman'" woman))) + +;;; Section Classes + +(defclass magit-commit-section (magit-section) + ((keymap :initform 'magit-commit-section-map))) + +(setf (alist-get 'commit magit--section-type-alist) 'magit-commit-section) + +(defclass magit-diff-section (magit-section) + ((keymap :initform 'magit-diff-section-map)) + :abstract t) + +(defclass magit-file-section (magit-diff-section) + ((keymap :initform 'magit-file-section-map) + (source :initform nil :initarg :source) + (header :initform nil :initarg :header) + (binary :initform nil :initarg :binary) + (heading-highlight-face :initform 'magit-diff-file-heading-highlight) + (heading-selection-face :initform 'magit-diff-file-heading-selection))) + +(defclass magit-module-section (magit-file-section) + ((keymap :initform 'magit-module-section-map) + (range :initform nil :initarg :range))) + +(defclass magit-hunk-section (magit-diff-section) + ((keymap :initform 'magit-hunk-section-map) + (painted :initform nil) + (refined :initform nil) + (combined :initform nil :initarg :combined) + (from-range :initform nil :initarg :from-range) + (from-ranges :initform nil) + (to-range :initform nil :initarg :to-range) + (about :initform nil :initarg :about) + (heading-highlight-face :initform 'magit-diff-hunk-heading-highlight) + (heading-selection-face :initform 'magit-diff-hunk-heading-selection))) + +(setf (alist-get 'file magit--section-type-alist) 'magit-file-section) +(setf (alist-get 'module magit--section-type-alist) 'magit-module-section) +(setf (alist-get 'hunk magit--section-type-alist) 'magit-hunk-section) + +(defclass magit-log-section (magit-section) + ((keymap :initform 'magit-log-section-map)) + :abstract t) +(defclass magit-unpulled-section (magit-log-section) ()) +(defclass magit-unpushed-section (magit-log-section) ()) +(defclass magit-unmerged-section (magit-log-section) ()) + +(setf (alist-get 'unpulled magit--section-type-alist) 'magit-unpulled-section) +(setf (alist-get 'unpushed magit--section-type-alist) 'magit-unpushed-section) +(setf (alist-get 'unmerged magit--section-type-alist) 'magit-unmerged-section) + +;;; User Input + +(defvar helm-completion-in-region-default-sort-fn) +(defvar helm-crm-default-separator) +(defvar ivy-sort-functions-alist) +(defvar ivy-sort-matches-functions-alist) +(defvar vertico-sort-function) + +(defvar magit-completing-read--silent-default nil) + +(defvar magit-completing-read-default-prompt-predicate + (lambda () + (and (eq magit-completing-read-function + 'magit-builtin-completing-read) + (not (or (bound-and-true-p helm-mode) + (bound-and-true-p ivy-mode) + (bound-and-true-p selectrum-mode) + (bound-and-true-p vertico-mode))))) + "Function used to determine whether to add default to prompt. + +This is used by `magit-completing-read' (which see). + +The default function returns nil, when a completion frameworks is used +for which this is undesirable. More precisely, it returns nil, when +`magit-completing-read-function' is not `magit-builtin-completing-read', +or one of `helm-mode', `ivy-mode', `selectrum-mode' or `vertico-mode' +is enabled. When this function returns nil, then nil is passed to +`format-prompt' (which see), instead of the default (DEF or FALLBACK).") + +(defun magit-completing-read ( prompt collection &optional + predicate require-match initial-input + hist def fallback) + "Read a choice in the minibuffer, or use the default choice. + +This is the function that Magit commands use when they need the +user to select a single thing to act on. The arguments have the +same meaning as for `completing-read', except for FALLBACK, which +is unique to this function and is described below. + +Instead of asking the user to choose from a list of possible +candidates, this function may instead just return the default +specified by DEF, with or without requiring user confirmation. +Whether that is the case depends on PROMPT, `this-command' and +`magit-dwim-selection'. See the documentation of the latter for +more information. + +If it does use the default without the user even having to +confirm that, then `magit-completing-read--silent-default' is set +to t, otherwise nil. + +If it does read a value in the minibuffer, then this function +acts similarly to `completing-read', except for the following: + +- COLLECTION must be a list of choices. A function is not + supported. + +- If REQUIRE-MATCH is nil and the user exits without a choice, + then nil is returned instead of an empty string. + +- If REQUIRE-MATCH is non-nil and the user exits without a + choice, `user-error' is raised. + +- FALLBACK specifies a secondary default that is only used if + the primary default DEF is nil. The secondary default is not + subject to `magit-dwim-selection' — if DEF is nil but FALLBACK + is not, then this function always asks the user to choose a + candidate, just as if both defaults were nil. + +- `format-prompt' is called on PROMPT and DEF (or FALLBACK if + DEF is nil). This appends \": \" to the prompt and may also + add the default to the prompt, using the format specified by + `minibuffer-default-prompt-format' and depending on + `magit-completing-read-default-prompt-predicate'." + (setq magit-completing-read--silent-default nil) + (if-let ((dwim (and def + (nth 2 (seq-find (pcase-lambda (`(,cmd ,re ,_)) + (and (eq this-command cmd) + (or (not re) + (string-match-p re prompt)))) + magit-dwim-selection))))) + (if (eq dwim 'ask) + (if (y-or-n-p (format "%s %s? " prompt def)) + def + (user-error "Abort")) + (setq magit-completing-read--silent-default t) + def) + (unless def + (setq def fallback)) + (when (and def + (not (functionp collection)) + (not (member def collection))) + (setq collection (cons def collection))) + (let ((command this-command) + (reply (funcall magit-completing-read-function + (magit--format-prompt prompt def) + collection predicate + require-match initial-input hist def))) + (setq this-command command) + ;; Note: Avoid `string=' to support `helm-comp-read-use-marked'. + (if (equal reply "") + (if (and require-match + (not (and (listp collection) + (member "" collection)))) + (user-error "Nothing selected") + nil) + reply)))) + +(defun magit--format-prompt (prompt default) + (format-prompt (if (string-suffix-p ": " prompt) + (substring prompt 0 -2) + prompt) + (and (funcall magit-completing-read-default-prompt-predicate) + default))) + +(defun magit--completion-table (collection) + (lambda (string pred action) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity)) + (complete-with-action action collection string pred)))) + +(defun magit-builtin-completing-read + (prompt choices &optional predicate require-match initial-input hist def) + "Magit wrapper for standard `completing-read' function." + (unless (or (bound-and-true-p helm-mode) + (bound-and-true-p ivy-mode)) + (setq choices (magit--completion-table choices))) + (let ((ivy-sort-functions-alist nil)) + (completing-read prompt + (lambda (str pred action) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity) + (cycle-sort-function . identity)) + (complete-with-action action choices str pred))) + predicate require-match + initial-input hist def))) + +(define-obsolete-function-alias 'magit-completing-read-multiple* + 'magit-completing-read-multiple "Magit-Section 4.0.0") + +(defun magit-completing-read-multiple + ( prompt table &optional predicate require-match initial-input + hist def inherit-input-method + no-split) + "Read multiple strings in the minibuffer, with completion. +Like `completing-read-multiple' but don't mess with order of +TABLE and take an additional argument NO-SPLIT, which causes +the user input to be returned as a single unmodified string. +Also work around various incompatible features of various +third-party completion frameworks." + (cl-letf* + (;; To implement NO-SPLIT we have to manipulate the respective + ;; `split-string' invocation. We cannot simply advice it to + ;; return the input string because `SELECTRUM' would choke on + ;; that string. Use a variable to pass along the raw user + ;; input string. aa5f098ab + (input nil) + (split-string (symbol-function #'split-string)) + ((symbol-function #'split-string) + (lambda (string &optional separators omit-nulls trim) + (when (and no-split + (equal separators crm-separator) + (equal omit-nulls t)) + (setq input string)) + (funcall split-string string separators omit-nulls trim))) + ;; Prevent `BUILT-IN' completion from messing up our existing + ;; order of the completion candidates. aa5f098ab + (table (magit--completion-table table)) + ;; Prevent `IVY' from messing up our existing order. c7af78726 + (ivy-sort-matches-functions-alist nil) + ;; Prevent `HELM' from messing up our existing order. 6fcf994bd + (helm-completion-in-region-default-sort-fn nil) + ;; Prevent `HELM' from automatically appending the separator, + ;; which is counterproductive when NO-SPLIT is non-nil and/or + ;; when reading commit ranges. 798aff564 + (helm-crm-default-separator + (if no-split nil (bound-and-true-p helm-crm-default-separator))) + ;; And now, the moment we have all been waiting for... + (values (completing-read-multiple + (magit--format-prompt prompt def) + table predicate require-match initial-input + hist def inherit-input-method))) + (if no-split input values))) + +(defvar-keymap magit-minibuffer-local-ns-map + :parent minibuffer-local-map + "SPC" #'magit-whitespace-disallowed + "TAB" #'magit-whitespace-disallowed) + +(defun magit-whitespace-disallowed () + "Beep to tell the user that whitespace is not allowed." + (interactive) + (ding) + (message "Whitespace isn't allowed here") + (setq defining-kbd-macro nil) + (force-mode-line-update)) + +(defun magit-read-string ( prompt &optional initial-input history default-value + inherit-input-method no-whitespace) + "Read a string from the minibuffer, prompting with string PROMPT. + +This is similar to `read-string', but +* empty input is only allowed if DEFAULT-VALUE is non-nil in + which case that is returned, +* whitespace is not allowed and leading and trailing whitespace is + removed automatically if NO-WHITESPACE is non-nil, +* `format-prompt' is used internally. +* an invalid DEFAULT-VALUE is silently ignored." + (when default-value + (when (consp default-value) + (setq default-value (car default-value))) + (unless (stringp default-value) + (setq default-value nil))) + (let* ((minibuffer-completion-table nil) + (val (read-from-minibuffer + (format-prompt prompt default-value) + initial-input (and no-whitespace magit-minibuffer-local-ns-map) + nil history default-value inherit-input-method)) + (trim (lambda (regexp string) + (save-match-data + (if (string-match regexp string) + (replace-match "" t t string) + string))))) + (when (and (string= val "") default-value) + (setq val default-value)) + (when no-whitespace + (setq val (funcall trim "\\`\\(?:[ \t\n\r]+\\)" + (funcall trim "\\(?:[ \t\n\r]+\\)\\'" val)))) + (cond ((string= val "") + (user-error "Need non-empty input")) + ((and no-whitespace (string-match-p "[\s\t\n]" val)) + (user-error "Input contains whitespace")) + (t val)))) + +(defun magit-read-string-ns ( prompt &optional initial-input history + default-value inherit-input-method) + "Call `magit-read-string' with non-nil NO-WHITESPACE." + (magit-read-string prompt initial-input history default-value + inherit-input-method t)) + +(defmacro magit-read-char-case (prompt verbose &rest clauses) + (declare (indent 2) + (debug (form form &rest (characterp form body)))) + `(prog1 (pcase (read-char-choice + (let ((parts (nconc (list ,@(mapcar #'cadr clauses)) + ,(and verbose '(list "[C-g] to abort"))))) + (concat ,prompt + (string-join (butlast parts) ", ") + ", or " (car (last parts)) " ")) + ',(mapcar #'car clauses)) + ,@(mapcar (##`(,(car %) ,@(cddr %))) clauses)) + (message ""))) + +(defun magit-y-or-n-p (prompt &optional action) + "Ask user a \"y or n\" or a \"yes or no\" question using PROMPT. +Which kind of question is used depends on whether +ACTION is a member of option `magit-slow-confirm'." + (if (or (eq magit-slow-confirm t) + (and action (member action magit-slow-confirm))) + (yes-or-no-p prompt) + (y-or-n-p prompt))) + +(defvar magit--no-confirm-alist + '((safe-with-wip magit-wip-before-change-mode + discard reverse stage-all-changes unstage-all-changes))) + +(cl-defun magit-confirm ( action &optional prompt prompt-n noabort + (items nil sitems) prompt-suffix) + (declare (indent defun)) + (when (and prompt (listp prompt)) + (setq prompt + (apply #'format (car prompt) + (mapcar (##if (stringp %) (string-replace "%" "%%" %) %) + (cdr prompt))))) + (when (and prompt-n (listp prompt-n)) + (setq prompt-n + (apply #'format (car prompt-n) + (mapcar (##if (stringp %) (string-replace "%" "%%" %) %) + (cdr prompt-n))))) + (setq prompt-n (format (concat (or prompt-n prompt) "? ") (length items))) + (setq prompt (format (concat (or prompt (magit-confirm-make-prompt action)) + "? ") + (car items))) + (when prompt-suffix + (setq prompt (concat prompt prompt-suffix))) + (or (cond ((and (not (eq action t)) + (or (eq magit-no-confirm t) + (memq action magit-no-confirm) + (cl-member-if (pcase-lambda (`(,key ,var . ,sub)) + (and (memq key magit-no-confirm) + (memq action sub) + (or (not var) + (and (boundp var) + (symbol-value var))))) + magit--no-confirm-alist))) + (or (not sitems) items)) + ((not sitems) + (magit-y-or-n-p prompt action)) + ((length= items 1) + (and (magit-y-or-n-p prompt action) items)) + ((length> items 1) + (and (magit-y-or-n-p (concat (string-join items "\n") + "\n\n" prompt-n) + action) + items))) + (if noabort nil (user-error "Abort")))) + +(defun magit-confirm-files (action files &optional prompt prompt-suffix noabort) + (when files + (unless prompt + (setq prompt (magit-confirm-make-prompt action))) + (magit-confirm action + (concat prompt " \"%s\"") + (concat prompt " %d files") + noabort files prompt-suffix))) + +(defun magit-confirm-make-prompt (action) + (let ((prompt (symbol-name action))) + (string-replace "-" " " + (concat (upcase (substring prompt 0 1)) + (substring prompt 1))))) + +(defun magit-read-number-string (prompt &optional default _history) + "Like `read-number' but return value is a string. +DEFAULT may be a number or a numeric string." + (number-to-string + (read-number prompt (if (stringp default) + (string-to-number default) + default)))) + +;;; Debug Utilities + +;;;###autoload +(defun magit-emacs-Q-command () + "Show a shell command that runs an uncustomized Emacs with only Magit loaded. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (let ((cmd (mapconcat + #'shell-quote-argument + `(,(concat invocation-directory invocation-name) + "-Q" "--eval" "(setq debug-on-error t)" + ,@(mapcan + (##list "-L" %) + (delete-dups + (mapcan + (lambda (lib) + (if-let ((path (locate-library lib))) + (list (file-name-directory path)) + (error "Cannot find mandatory dependency %s" lib))) + '(;; Like `LOAD_PATH' in `default.mk'. + "compat" + "llama" + "seq" + "transient" + "with-editor" + ;; Obviously `magit' itself is needed too. + "magit" + ;; While this is part of the Magit repository, + ;; it is distributed as a separate package. + "magit-section")))) + ;; Avoid Emacs bug#16406 by using full path. + "-l" ,(file-name-sans-extension (locate-library "magit"))) + " "))) + (message "Uncustomized Magit command saved to kill-ring, %s" + "please run it in a terminal.") + (kill-new cmd))) + +;;; Text Utilities + +(defmacro magit-bind-match-strings (varlist string &rest body) + "Bind variables to submatches according to VARLIST then evaluate BODY. +Bind the symbols in VARLIST to submatches of the current match +data, starting with 1 and incrementing by 1 for each symbol. If +the last match was against a string, then that has to be provided +as STRING." + (declare (indent 2) (debug (listp form body))) + (let ((s (gensym "string")) + (i 0)) + `(let ((,s ,string)) + (let ,(save-match-data + (mapcan (lambda (sym) + (cl-incf i) + (and (not (eq (aref (symbol-name sym) 0) ?_)) + (list (list sym (list 'match-string i s))))) + varlist)) + ,@body)))) + +(defun magit-delete-line () + "Delete the rest of the current line." + (delete-region (point) (1+ (line-end-position)))) + +(defun magit-delete-match (&optional num) + "Delete text matched by last search. +If optional NUM is specified, only delete that subexpression." + (delete-region (match-beginning (or num 0)) + (match-end (or num 0)))) + +(defun magit-file-line (file) + "Return the first line of FILE as a string." + (and (file-regular-p file) + (with-temp-buffer + (insert-file-contents file) + (buffer-substring-no-properties (point-min) + (line-end-position))))) + +(defun magit-file-lines (file &optional keep-empty-lines) + "Return a list of strings containing one element per line in FILE. +Unless optional argument KEEP-EMPTY-LINES is t, trim all empty lines." + (and (file-regular-p file) + (with-temp-buffer + (insert-file-contents file) + (split-string (buffer-string) "\n" (not keep-empty-lines))))) + +(defun magit-set-header-line-format (string) + "Set `header-line-format' in the current buffer based on STRING. +Pad the left side of STRING so that it aligns with the text area." + (setq header-line-format + (concat (propertize " " 'display '(space :align-to 0)) + string))) + +(defun magit--format-spec (format specification) + "Like `format-spec' but preserve text properties in SPECIFICATION." + (with-temp-buffer + (insert format) + (goto-char (point-min)) + (while (search-forward "%" nil t) + (cond + ;; Quoted percent sign. + ((eq (char-after) ?%) + (delete-char 1)) + ;; Valid format spec. + ((looking-at "\\([-0-9.]*\\)\\([a-zA-Z]\\)") + (let* ((num (match-string 1)) + (spec (string-to-char (match-string 2))) + (val (assq spec specification))) + (unless val + (error "Invalid format character: `%%%c'" spec)) + (setq val (cdr val)) + ;; Pad result to desired length. + (let ((text (format (concat "%" num "s") val))) + ;; Insert first, to preserve text properties. + (if (next-property-change 0 (concat " " text)) + ;; If the inserted text has properties, then preserve those. + (insert text) + ;; Otherwise preserve FORMAT's properties, like `format-spec'. + (insert-and-inherit text)) + ;; Delete the specifier body. + (delete-region (+ (match-beginning 0) (length text)) + (+ (match-end 0) (length text))) + ;; Delete the percent sign. + (delete-region (1- (match-beginning 0)) (match-beginning 0))))) + ;; Signal an error on bogus format strings. + (t + (error "Invalid format string")))) + (buffer-string))) + +;;; Missing from Emacs + +(defun magit-kill-this-buffer () + "Kill the current buffer." + (interactive) + (kill-buffer (current-buffer))) + +(defun magit--buffer-string (&optional min max trim) + "Like `buffer-substring-no-properties' but the arguments are optional. + +This combines the benefits of `buffer-string', `buffer-substring' +and `buffer-substring-no-properties' into one function that is +not as painful to use as the latter. I.e., you can write + (magit--buffer-string) +instead of + (buffer-substring-no-properties (point-min) + (point-max)) + +Optional MIN defaults to the value of `point-min'. +Optional MAX defaults to the value of `point-max'. + +If optional TRIM is non-nil, then all leading and trailing +whitespace is remove. If it is the newline character, then +one trailing newline is added." + ;; Lets write that one last time and be done with it: + (let ((str (buffer-substring-no-properties (or min (point-min)) + (or max (point-max))))) + (if trim + (concat (string-trim str) + (and (eq trim ?\n) "\n")) + str))) + +(defun magit--separate (pred list) + "Separate elements of LIST that do and don't satisfy PRED. +Return a list of two lists; the first containing the elements that +do satisfy PRED and the second containing the elements that don't." + (let (y n) + (dolist (elt list) + (push elt (if (funcall pred elt) y n))) + (list (nreverse y) + (nreverse n)))) + +(defun magit--version> (v1 v2) + "Return t if version V1 is higher (younger) than V2. +This function should be named `version>' and be part of Emacs." + (version-list-< (version-to-list v2) (version-to-list v1))) + +(defun magit--version>= (v1 v2) + "Return t if version V1 is higher (younger) than or equal to V2. +This function should be named `version>=' and be part of Emacs." + (version-list-<= (version-to-list v2) (version-to-list v1))) + +;;; Kludges for Emacs Bugs + +(defun magit-which-function () + "Return current function name based on point, without caching. + +This is a simple wrapper around `which-function', that resets +Imenu's potentially outdated and therefore unreliable cache by +setting `imenu--index-alist' to nil before calling that function." + (setq imenu--index-alist nil) + (which-function)) + +;;; Kludges for Custom + +(defun magit-custom-initialize-reset (symbol exp) + "Initialize SYMBOL based on EXP. +Set the value of the variable SYMBOL, using `set-default' +\(unlike `custom-initialize-reset', which uses the `:set' +function if any). The value is either the symbol's current +value (as obtained using the `:get' function), if any, or +the value in the symbol's `saved-value' property if any, or +\(last of all) the value of EXP." + (set-default-toplevel-value + symbol + (condition-case nil + (let ((def (default-toplevel-value symbol)) + (getter (get symbol 'custom-get))) + (if getter (funcall getter symbol) def)) + (error + (eval (let ((sv (get symbol 'saved-value))) + (if sv (car sv) exp))))))) + +(defun magit-hook-custom-get (symbol) + (if (symbol-file symbol 'defvar) + (default-toplevel-value symbol) + ;; + ;; Called by `custom-initialize-reset' on behalf of `symbol's + ;; `defcustom', which is being evaluated for the first time to + ;; set the initial value, but there's already a default value, + ;; which most likely was established by one or more `add-hook' + ;; calls. + ;; + ;; We combine the `standard-value' and the current value, while + ;; preserving the order established by `:options', and return + ;; the result of that to be used as the "initial" default value. + ;; + (let ((standard (eval (car (get symbol 'standard-value)))) + (current (default-toplevel-value symbol)) + (value nil)) + (dolist (fn (get symbol 'custom-options)) + (when (or (memq fn standard) + (memq fn current)) + (push fn value))) + (dolist (fn current) + (unless (memq fn value) + (push fn value))) + (nreverse value)))) + +;;; Kludges for Info Manuals + +;;;###autoload +(define-advice Info-follow-nearest-node (:around (fn &optional fork) gitman) + (let ((node (Info-get-token + (point) "\\*note[ \n\t]+" + "\\*note[ \n\t]+\\([^:]*\\):\\(:\\|[ \n\t]*(\\)?"))) + (if (and node (string-match "^(gitman)\\(.+\\)" node)) + (pcase magit-view-git-manual-method + ('info (funcall fn fork)) + ('man (require 'man) + (man (match-string 1 node))) + ('woman (require 'woman) + (woman (match-string 1 node))) + (_ (user-error "Invalid value for `magit-view-git-manual-method'"))) + (funcall fn fork)))) + +;; When making changes here, then also adjust the copy in docs/Makefile. +;;;###autoload +(define-advice org-man-export (:around (fn link description format) gitman) + (if (and (eq format 'texinfo) + (string-prefix-p "git" link)) + (string-replace "%s" link " +@ifinfo +@ref{%s,,,gitman,}. +@end ifinfo +@ifhtml +@html +the %s(1) manpage. +@end html +@end ifhtml +@iftex +the %s(1) manpage. +@end iftex +") + (funcall fn link description format))) + +;;; Kludges for Package Managers + +(defun magit--chase-links (filename) + "Chase links in FILENAME until a name that is not a link. + +This is the same as `file-chase-links', except that it also handles +fake symlinks that are created by some source based package managers +\(Elpaca and Straight) on Windows. + +See ." + (when-let* + ((manager (cond ((bound-and-true-p straight-symlink-mode) 'straight) + ((bound-and-true-p elpaca-no-symlink-mode) 'elpaca))) + (build (pcase manager + ('straight (bound-and-true-p straight-build-dir)) + ('elpaca (bound-and-true-p elpaca-builds-directory)))) + ((string-prefix-p build filename)) + (repo (pcase manager + ('straight + (and (bound-and-true-p straight-base-dir) + (expand-file-name "repos/magit/lisp/" straight-base-dir))) + ('elpaca + (and (bound-and-true-p elpaca-repos-directory) + (expand-file-name "magit/lisp/" elpaca-repos-directory)))))) + (setq filename (expand-file-name (file-name-nondirectory filename) repo))) + (file-chase-links filename)) + +;;; Miscellaneous + +(defun magit-message (format-string &rest args) + "Display a message at the bottom of the screen, or not. +Like `message', except that if the users configured option +`magit-no-message' to prevent the message corresponding to +FORMAT-STRING to be displayed, then don't." + (unless (seq-find (##string-prefix-p % format-string) magit-no-message) + (apply #'message format-string args))) + +(defun magit-msg (format-string &rest args) + "Display a message at the bottom of the screen, but don't log it. +Like `message', except that `message-log-max' is bound to nil." + (let ((message-log-max nil)) + (apply #'message format-string args))) + +(defmacro magit--with-temp-position (buf pos &rest body) + (declare (indent 2)) + `(with-current-buffer ,buf + (save-excursion + (save-restriction + (widen) + (goto-char (or ,pos 1)) + ,@body)))) + +(defun magit--ellipsis (&optional where) + "Build an ellipsis always as string, depending on WHERE." + (if (stringp magit-ellipsis) + magit-ellipsis + (if-let ((pair (car (or + (alist-get (or where t) magit-ellipsis) + (alist-get t magit-ellipsis))))) + (pcase-let ((`(,fancy . ,universal) pair)) + (let ((ellipsis (if (and fancy (char-displayable-p fancy)) + fancy + universal))) + (if (characterp ellipsis) + (char-to-string ellipsis) + ellipsis))) + (user-error "Variable magit-ellipsis is invalid")))) + +(defun magit--ext-regexp-quote (string) + "Like `reqexp-quote', but for Extended Regular Expressions." + (let ((special (string-to-list "[*.\\?+^$({")) + (quoted nil)) + (dolist (char string) + (when (memq char special) + (push ?\\ quoted)) + (push char quoted)) + (concat (nreverse quoted)))) + +;;; _ +(provide 'magit-base) +;;; magit-base.el ends here blob - /dev/null blob + 8c737c13c0a6c134a5eace5bbefbeceb83e00ce8 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-bisect.el @@ -0,0 +1,318 @@ +;;; magit-bisect.el --- Bisect support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Use a binary search to find the commit that introduced a bug. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-bisect-show-graph t + "Whether to use `--graph' in the log showing commits yet to be bisected." + :package-version '(magit . "2.8.0") + :group 'magit-status + :type 'boolean) + +(defface magit-bisect-good + '((t :foreground "DarkOliveGreen")) + "Face for good bisect revisions." + :group 'magit-faces) + +(defface magit-bisect-skip + '((t :foreground "DarkGoldenrod")) + "Face for skipped bisect revisions." + :group 'magit-faces) + +(defface magit-bisect-bad + '((t :foreground "IndianRed4")) + "Face for bad bisect revisions." + :group 'magit-faces) + +;;; Commands + +;;;###autoload (autoload 'magit-bisect "magit-bisect" nil t) +(transient-define-prefix magit-bisect () + "Narrow in on the commit that introduced a bug." + :man-page "git-bisect" + [:class transient-subgroups + :if-not magit-bisect-in-progress-p + ["Arguments" + ("-n" "Don't checkout commits" "--no-checkout") + ("-p" "Follow only first parent of a merge" "--first-parent" + :if (##magit-git-version>= "2.29")) + (magit-bisect:--term-old :level 6) + (magit-bisect:--term-new :level 6)] + ["Actions" + ("B" "Start" magit-bisect-start) + ("s" "Start script" magit-bisect-run)]] + ["Actions" + :if magit-bisect-in-progress-p + ("B" "Bad" magit-bisect-bad) + ("g" "Good" magit-bisect-good) + ("m" "Mark" magit-bisect-mark :level 6) + ("k" "Skip" magit-bisect-skip) + ("r" "Reset" magit-bisect-reset) + ("s" "Run script" magit-bisect-run)]) + +(transient-define-argument magit-bisect:--term-old () + :description "Old/good term" + :class 'transient-option + :key "=o" + :argument "--term-old=") + +(transient-define-argument magit-bisect:--term-new () + :description "New/bad term" + :class 'transient-option + :key "=n" + :argument "--term-new=") + +;;;###autoload +(defun magit-bisect-start (bad good args) + "Start a bisect session. + +Bisecting a bug means to find the commit that introduced it. +This command starts such a bisect session by asking for a known +good and a known bad commit. To move the session forward use the +other actions from the bisect transient command (\ +\\\\[magit-bisect])." + (interactive (if (magit-bisect-in-progress-p) + (user-error "Already bisecting") + (magit-bisect-start-read-args))) + (magit-bisect-start--assert bad good args) + (magit-repository-local-set 'bisect--first-parent + (transient-arg-value "--first-parent" args)) + (magit-git-bisect "start" (list args bad good) t)) + +(defun magit-bisect-start-read-args () + (let* ((args (transient-args 'magit-bisect)) + (bad (magit-read-branch-or-commit + (format "Start bisect with %s revision" + (or (transient-arg-value "--term-new=" args) + "bad"))))) + (list bad + (magit-read-other-branch-or-commit + (format "%s revision" (or (transient-arg-value "--term-old=" args) + "Good")) + bad) + args))) + +(defun magit-bisect-start--assert (bad good args) + (unless (magit-rev-ancestor-p good bad) + (user-error + "The %s revision (%s) has to be an ancestor of the %s one (%s)" + (or (transient-arg-value "--term-old=" args) "good") + good + (or (transient-arg-value "--term-new=" args) "bad") + bad)) + (when (magit-anything-modified-p) + (user-error "Cannot bisect with uncommitted changes"))) + +;;;###autoload +(defun magit-bisect-reset () + "After bisecting, cleanup bisection state and return to original `HEAD'." + (interactive) + (magit-confirm 'reset-bisect) + (magit-run-git "bisect" "reset") + (magit-repository-local-delete 'bisect--first-parent) + (ignore-errors + (delete-file (expand-file-name "BISECT_CMD_OUTPUT" (magit-gitdir))))) + +;;;###autoload +(defun magit-bisect-good () + "While bisecting, mark the current commit as good. +Use this after you have asserted that the commit does not contain +the bug in question." + (interactive) + (magit-git-bisect (or (cadr (magit-bisect-terms)) + (user-error "Not bisecting")))) + +;;;###autoload +(defun magit-bisect-bad () + "While bisecting, mark the current commit as bad. +Use this after you have asserted that the commit does contain the +bug in question." + (interactive) + (magit-git-bisect (or (car (magit-bisect-terms)) + (user-error "Not bisecting")))) + +;;;###autoload +(defun magit-bisect-mark () + "While bisecting, mark the current commit with a bisect term. +During a bisect using alternate terms, commits can still be +marked with `magit-bisect-good' and `magit-bisect-bad', as those +commands map to the correct term (\"good\" to --term-old's value +and \"bad\" to --term-new's). However, in some cases, it can be +difficult to keep that mapping straight in your head; this +command provides an interface that exposes the underlying terms." + (interactive) + (magit-git-bisect + (pcase-let ((`(,term-new ,term-old) (or (magit-bisect-terms) + (user-error "Not bisecting")))) + (pcase (read-char-choice + (format "Mark HEAD as %s ([n]ew) or %s ([o]ld)" + term-new term-old) + (list ?n ?o)) + (?n term-new) + (?o term-old))))) + +;;;###autoload +(defun magit-bisect-skip () + "While bisecting, skip the current commit. +Use this if for some reason the current commit is not a good one +to test. This command lets Git choose a different one." + (interactive) + (magit-git-bisect "skip")) + +;;;###autoload +(defun magit-bisect-run (cmdline &optional bad good args) + "Bisect automatically by running commands after each step. + +Unlike `git bisect run' this can be used before bisecting has +begun. In that case it behaves like `git bisect start; git +bisect run'." + (interactive (let ((args (and (not (magit-bisect-in-progress-p)) + (magit-bisect-start-read-args)))) + (cons (read-shell-command "Bisect shell command: ") args))) + (when (and bad good) + (magit-bisect-start--assert bad good args) + ;; Avoid `magit-git-bisect' because it's asynchronous, but the + ;; next `git bisect run' call requires the bisect to be started. + (magit-with-toplevel + (magit-process-git + (list :file (expand-file-name "BISECT_CMD_OUTPUT" (magit-gitdir))) + "bisect" "start" bad good args) + (magit-refresh))) + (with-connection-local-variables + (magit-git-bisect "run" (list shell-file-name + shell-command-switch cmdline)))) + +(defun magit-git-bisect (subcommand &optional args no-assert) + (unless (or no-assert (magit-bisect-in-progress-p)) + (user-error "Not bisecting")) + (message "Bisecting...") + (magit-with-toplevel + (magit-run-git-async "bisect" subcommand args)) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (when-let* ((section (magit-section-at)) + (output (buffer-substring-no-properties + (oref section content) + (oref section end)))) + (with-temp-file + (expand-file-name "BISECT_CMD_OUTPUT" (magit-gitdir)) + (insert output))))) + (magit-refresh)) + (message "Bisecting...done"))))) + +;;; Sections + +(defun magit-bisect-in-progress-p () + (file-exists-p (expand-file-name "BISECT_LOG" (magit-gitdir)))) + +(defun magit-bisect-terms () + (magit-file-lines (expand-file-name "BISECT_TERMS" (magit-gitdir)))) + +(defun magit-insert-bisect-output () + "While bisecting, insert section with output from `git bisect'." + (when (magit-bisect-in-progress-p) + (let* ((lines + (or (magit-file-lines + (expand-file-name "BISECT_CMD_OUTPUT" (magit-gitdir))) + (list "Bisecting: (no saved bisect output)" + "It appears you have invoked `git bisect' from a shell." + "There is nothing wrong with that, we just cannot display" + "anything useful here. Consult the shell output instead."))) + (done-re "^\\([a-z0-9]\\{40,\\}\\) is the first bad commit$") + (bad-line (or (and (string-match done-re (car lines)) + (pop lines)) + (seq-find (##string-match done-re %) lines)))) + (magit-insert-section ((eval (if bad-line 'commit 'bisect-output)) + (and bad-line (match-string 1 bad-line))) + (magit-insert-heading + (propertize (or bad-line (pop lines)) + 'font-lock-face 'magit-section-heading)) + (dolist (line lines) + (insert line "\n")))) + (insert "\n"))) + +(defun magit-insert-bisect-rest () + "While bisecting, insert section visualizing the bisect state." + (when (magit-bisect-in-progress-p) + (magit-insert-section (bisect-view) + (magit-insert-heading t "Bisect Rest") + (magit-git-wash (apply-partially #'magit-log-wash-log 'bisect-vis) + "bisect" "visualize" "git" "log" + "--format=%h%x00%D%x00%s" "--decorate=full" + (and magit-bisect-show-graph "--graph") + (and (magit-repository-local-get 'bisect--first-parent) + "--first-parent"))))) + +(defun magit-insert-bisect-log () + "While bisecting, insert section logging bisect progress." + (when (magit-bisect-in-progress-p) + (magit-insert-section (bisect-log) + (magit-insert-heading t "Bisect Log") + (magit-git-wash #'magit-wash-bisect-log "bisect" "log") + (insert ?\n)))) + +(defun magit-wash-bisect-log (_args) + (let (beg) + (while (progn (setq beg (point-marker)) + (re-search-forward + "^\\(\\(?:git bisect\\|# status:\\) [^\n]+\n\\)" nil t)) + (if (string-prefix-p "# status:" (match-string 1)) + (magit-delete-match) + (magit-bind-match-strings (heading) nil + (magit-delete-match) + (save-restriction + (narrow-to-region beg (point)) + (goto-char (point-min)) + (magit-insert-section (bisect-item heading t) + (magit-insert-heading + (propertize heading 'font-lock-face + 'magit-section-secondary-heading)) + (magit-wash-sequence + (apply-partially #'magit-log-wash-rev 'bisect-log + (magit-abbrev-length))) + (insert ?\n)))))) + (when (re-search-forward + "# first bad commit: \\[\\([a-z0-9]\\{40,\\}\\)\\] [^\n]+\n" nil t) + (magit-bind-match-strings (hash) nil + (magit-delete-match) + (magit-insert-section (bisect-item) + (insert hash " is the first bad commit\n")))))) + +;;; _ +(provide 'magit-bisect) +;;; magit-bisect.el ends here blob - /dev/null blob + e87bd4fc4ecd41962478f99cf258481f4c369e98 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-blame.el @@ -0,0 +1,1005 @@ +;;; magit-blame.el --- Blame support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Annotates each line in file-visiting buffer with information from +;; the revision which last modified the line. + +;;; Code: + +(require 'magit) + +;;; Options + +(defgroup magit-blame nil + "Blame support for Magit." + :link '(info-link "(magit)Blaming") + :group 'magit-modes) + +(defcustom magit-blame-styles + '((headings + (heading-format . "%-20a %C %s\n")) + (highlight + (highlight-face . magit-blame-highlight)) + (lines + (show-lines . t) + (show-message . t))) + "List of styles used to visualize blame information. + +The style used in the current buffer can be cycled from the blame +popup. Blame commands (except `magit-blame-echo') use the first +style as the initial style when beginning to blame in a buffer. + +Each entry has the form (IDENT (KEY . VALUE)...). IDENT has +to be a symbol uniquely identifying the style. The following +KEYs are recognized: + + `show-lines' + Whether to prefix each chunk of lines with a thin line. + This has no effect if `heading-format' is non-nil. + `show-message' + Whether to display a commit's summary line in the echo area + when crossing chunks. + `highlight-face' + Face used to highlight the first line of each chunk. + If this is nil, then those lines are not highlighted. + `heading-format' + String specifying the information to be shown above each + chunk of lines. It must end with a newline character. + `margin-format' + String specifying the information to be shown in the left + buffer margin. It must NOT end with a newline character. + This can also be a list of formats used for the lines at + the same positions within the chunk. If the chunk has + more lines than formats are specified, then the last is + repeated. WARNING: Adding this key affects performance; + see the note at the end of this docstring. + `margin-width' + Width of the margin, provided `margin-format' is non-nil. + `margin-face' + Face used in the margin, provided `margin-format' is + non-nil. This face is used in combination with the faces + that are specific to the used %-specs. If this is nil, + then `magit-blame-margin' is used. + `margin-body-face' + Face used in the margin for all but first line of a chunk. + This face is used in combination with the faces that are + specific to the used %-specs. This can also be a list of + faces (usually one face), in which case only these faces + are used and the %-spec faces are ignored. A good value + might be `(magit-blame-dimmed)'. If this is nil, then + the same face as for the first line is used. + +The following %-specs can be used in `heading-format' and +`margin-format': + + %H hash using face `magit-blame-hash' + %h truncated hash using face `magit-blame-hash' + %s summary using face `magit-blame-summary' + %a author using face `magit-blame-name' + %A author time using face `magit-blame-date' + %c committer using face `magit-blame-name' + %C committer time using face `magit-blame-date' + +Note that for performance reasons %h results in truncated +hashes, as opposed to properly abbreviated hashes that are +guaranteed to uniquely identify a commit. + +Additionally if `margin-format' ends with %f, then the string +that is displayed in the margin is made at least `margin-width' +characters wide, which may be desirable if the used face sets +the background color. + +Blame information is displayed using overlays. Such extensive +use of overlays is known to slow down even basic operations, such +as moving the cursor. To reduce the number of overlays the margin +style had to be removed from the default value of this option. + +Note that the margin overlays are created even if another style +is currently active. This can only be prevented by not even +defining a style that uses the margin. If you want to use this +style anyway, you can restore this definition, which used to be +part of the default value: + + (margin + (margin-format . (\" %s%f\" \" %C %a\" \" %H\")) + (margin-width . 42) + (margin-face . magit-blame-margin) + (margin-body-face . (magit-blame-dimmed)))" + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'string) + +(defcustom magit-blame-echo-style 'lines + "The blame visualization style used by `magit-blame-echo'. +A symbol that has to be used as the identifier for one of the +styles defined in `magit-blame-styles'." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'symbol) + +(defcustom magit-blame-time-format "%F %H:%M" + "Format for time strings in blame headings." + :group 'magit-blame + :type 'string) + +(defcustom magit-blame-read-only t + "Whether to initially make the blamed buffer read-only." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'boolean) + +(defcustom magit-blame-disable-modes '(fci-mode yascroll-bar-mode) + "List of modes not compatible with Magit-Blame mode. +This modes are turned off when Magit-Blame mode is turned on, +and then turned on again when turning off the latter." + :group 'magit-blame + :type '(repeat (symbol :tag "Mode"))) + +(defcustom magit-blame-mode-lighter " Blame" + "The mode-line lighter of the Magit-Blame mode." + :group 'magit-blame + :type '(choice (const :tag "No lighter" "") string)) + +(defcustom magit-blame-goto-chunk-hook + (list #'magit-blame-maybe-update-revision-buffer + #'magit-blame-maybe-show-message) + "Hook run after point entered another chunk." + :package-version '(magit . "2.13.0") + :group 'magit-blame + :type 'hook + :get #'magit-hook-custom-get + :options (list #'magit-blame-maybe-update-revision-buffer + #'magit-blame-maybe-show-message)) + +;;; Faces + +(defface magit-blame-highlight + '((((class color) (background light)) + :extend t + :background "grey80" + :foreground "black") + (((class color) (background dark)) + :extend t + :background "grey25" + :foreground "white")) + "Face used for highlighting when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-margin + '((t :inherit magit-blame-highlight + :weight normal + :slant normal)) + "Face used for the blame margin by default when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-dimmed + '((t :inherit magit-dimmed + :weight normal + :slant normal)) + "Face used for the blame margin in some cases when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-heading + '((t :extend t + :inherit magit-blame-highlight + :weight normal + :slant normal)) + "Face used for blame headings by default when blaming. +Also see option `magit-blame-styles'." + :group 'magit-faces) + +(defface magit-blame-summary '((t nil)) + "Face used for commit summaries when blaming." + :group 'magit-faces) + +(defface magit-blame-hash '((t nil)) + "Face used for commit hashes when blaming." + :group 'magit-faces) + +(defface magit-blame-name '((t nil)) + "Face used for author and committer names when blaming." + :group 'magit-faces) + +(defface magit-blame-date '((t nil)) + "Face used for dates when blaming." + :group 'magit-faces) + +;;; Variables + +(defvar-local magit-blame-buffer-read-only nil) +(defvar-local magit-blame-cache nil) +(defvar-local magit-blame-disabled-modes nil) +(defvar-local magit-blame-process nil) +(defvar-local magit-blame-recursive-p nil) +(defvar-local magit-blame-type nil) +(defvar-local magit-blame-separator nil) +(defvar-local magit-blame-previous-chunk nil) + +(defvar-local magit-blame--make-margin-overlays nil) +(defvar-local magit-blame--style nil) + +;;; Chunks + +(defclass magit-blame-chunk () + (;; + (orig-rev :initarg :orig-rev) + (orig-line :initarg :orig-line) + (final-line :initarg :final-line) + (num-lines :initarg :num-lines) + ;; previous + (prev-rev :initform nil) + (prev-file :initform nil) + ;; filename + (orig-file))) + +(defun magit-current-blame-chunk (&optional type noerror) + (or (and (not (and type (not (eq type magit-blame-type)))) + (magit-blame-chunk-at (point))) + (and type + (let ((rev (or magit-buffer-refname magit-buffer-revision)) + (file (and (not (derived-mode-p 'dired-mode)) + (magit-file-relative-name + nil (not magit-buffer-file-name)))) + (line (format "%d,+1" (line-number-at-pos)))) + (cond (file (with-temp-buffer + (magit-with-toplevel + (magit-git-insert + "blame" "--porcelain" + (if (memq magit-blame-type '(final removal)) + (cons "--reverse" (magit-blame-arguments)) + (magit-blame-arguments)) + "-L" line rev "--" file) + (goto-char (point-min)) + (if (eobp) + (unless noerror + (error "Cannot get blame chunk at eob")) + (car (magit-blame--parse-chunk type)))))) + (noerror nil) + ((error "Buffer does not visit a tracked file"))))))) + +(defun magit-blame-chunk-at (pos) + (seq-some (##overlay-get % 'magit-blame-chunk) + (overlays-at pos))) + +(defun magit-blame--overlay-at (&optional pos key) + (unless pos + (setq pos (point))) + (seq-find (##overlay-get % (or key 'magit-blame-chunk)) + (nconc (overlays-at pos) + (overlays-in pos pos)))) + +;;; Keymaps + +(defvar-keymap magit-blame-mode-map + :doc "Keymap for `magit-blame-mode'. +Note that most blaming key bindings are defined +in `magit-blame-read-only-mode-map' instead." + "C-c C-q" #'magit-blame-quit) + +(defvar-keymap magit-blame-read-only-mode-map + :doc "Keymap for `magit-blame-read-only-mode'." + "C-m" #'magit-show-commit + "p" #'magit-blame-previous-chunk + "P" #'magit-blame-previous-chunk-same-commit + "n" #'magit-blame-next-chunk + "N" #'magit-blame-next-chunk-same-commit + "b" #'magit-blame-addition + "r" #'magit-blame-removal + "f" #'magit-blame-reverse + "B" #'magit-blame + "c" #'magit-blame-cycle-style + "q" #'magit-blame-quit + "M-w" #'magit-blame-copy-hash + "SPC" #'magit-diff-show-or-scroll-up + "S-SPC" #'magit-diff-show-or-scroll-down + "DEL" #'magit-diff-show-or-scroll-down) + +;;; Modes +;;;; Base Mode + +(define-minor-mode magit-blame-mode + "Display blame information inline." + :lighter magit-blame-mode-lighter + :interactive nil + (cond (magit-blame-mode + (unless arg + ;; Emacs < 28.1 doesn't support `:interactive'. + (setq magit-blame-mode nil) + (user-error + (concat "Don't call `magit-blame-mode' directly; " + "instead use `magit-blame'"))) + (add-hook 'after-save-hook #'magit-blame--refresh t t) + (add-hook 'post-command-hook #'magit-blame-goto-chunk-hook t t) + (add-hook 'before-revert-hook #'magit-blame--remove-overlays t t) + (add-hook 'after-revert-hook #'magit-blame--refresh t t) + (add-hook 'read-only-mode-hook #'magit-blame-toggle-read-only t t) + (setq magit-blame-buffer-read-only buffer-read-only) + (when (or magit-blame-read-only magit-buffer-file-name) + (read-only-mode 1)) + (dolist (mode magit-blame-disable-modes) + (when (and (boundp mode) (symbol-value mode)) + (funcall mode -1) + (push mode magit-blame-disabled-modes))) + (setq magit-blame-separator (magit-blame--format-separator)) + (unless magit-blame--style + (setq magit-blame--style (car magit-blame-styles))) + (setq magit-blame--make-margin-overlays + (and (cl-find-if (##assq 'margin-format (cdr %)) + magit-blame-styles))) + (magit-blame--update-margin 'enable)) + (t + (when (process-live-p magit-blame-process) + (kill-process magit-blame-process) + (while magit-blame-process + (sit-for 0.01))) ; avoid racing the sentinel + (remove-hook 'after-save-hook #'magit-blame--refresh t) + (remove-hook 'post-command-hook #'magit-blame-goto-chunk-hook t) + (remove-hook 'before-revert-hook #'magit-blame--remove-overlays t) + (remove-hook 'after-revert-hook #'magit-blame--refresh t) + (remove-hook 'read-only-mode-hook #'magit-blame-toggle-read-only t) + (unless magit-blame-buffer-read-only + (read-only-mode -1)) + (magit-blame-read-only-mode -1) + (dolist (mode magit-blame-disabled-modes) + (funcall mode 1)) + (kill-local-variable 'magit-blame-disabled-modes) + (kill-local-variable 'magit-blame-type) + (kill-local-variable 'magit-blame--style) + (magit-blame--update-margin 'disable) + (magit-blame--remove-overlays)))) + +(defun magit-blame--refresh () + (magit-blame--run (magit-blame-arguments))) + +(defun magit-blame-goto-chunk-hook () + (let ((chunk (magit-blame-chunk-at (point)))) + (when (cl-typep chunk 'magit-blame-chunk) + (unless (eq chunk magit-blame-previous-chunk) + (run-hooks 'magit-blame-goto-chunk-hook)) + (setq magit-blame-previous-chunk chunk)))) + +(defun magit-blame-toggle-read-only () + (magit-blame-read-only-mode (if buffer-read-only 1 -1))) + +;;;; Read-Only Mode + +(define-minor-mode magit-blame-read-only-mode + "Provide keybindings for Magit-Blame mode. + +This minor-mode provides the key bindings for Magit-Blame mode, +but only when Read-Only mode is also enabled because these key +bindings would otherwise conflict badly with regular bindings. + +When both Magit-Blame mode and Read-Only mode are enabled, then +this mode gets automatically enabled too and when one of these +modes is toggled, then this mode also gets toggled automatically. + +\\{magit-blame-read-only-mode-map}") + +;;;; Kludges + +(defun magit-blame-put-keymap-before-view-mode () + "Put `magit-blame-read-only-mode' ahead of `view-mode' in `minor-mode-map-alist'." + (when-let ((entry (assq 'magit-blame-read-only-mode + (cl-member 'view-mode minor-mode-map-alist + :key #'car)))) + (setq minor-mode-map-alist + (cons entry + (delq entry minor-mode-map-alist)))) + (remove-hook 'view-mode-hook #'magit-blame-put-keymap-before-view-mode)) + +(add-hook 'view-mode-hook #'magit-blame-put-keymap-before-view-mode) + +;;; Process + +(defun magit-blame--run (args) + (magit-with-toplevel + (unless magit-blame-mode + (magit-blame-mode 1)) + (message "Blaming...") + (magit-blame-run-process + (or magit-buffer-refname magit-buffer-revision) + (magit-file-relative-name nil (not magit-buffer-file-name)) + (if (memq magit-blame-type '(final removal)) + (cons "--reverse" args) + args) + (list (line-number-at-pos (window-start)) + (line-number-at-pos (1- (window-end nil t))))) + (set-process-sentinel magit-this-process + #'magit-blame-process-quickstart-sentinel))) + +(defun magit-blame-run-process (revision file args &optional lines) + (let ((process (magit-parse-git-async + "blame" "--incremental" args + (and lines (list "-L" (apply #'format "%s,%s" lines))) + revision "--" file))) + (set-process-filter process #'magit-blame-process-filter) + (set-process-sentinel process #'magit-blame-process-sentinel) + (process-put process 'arguments (list revision file args)) + (setq magit-blame-cache (make-hash-table :test #'equal)) + (setq magit-blame-process process))) + +(defun magit-blame-process-quickstart-sentinel (process event) + (when (memq (process-status process) '(exit signal)) + (magit-blame-process-sentinel process event t) + (magit-blame-assert-buffer process) + (with-current-buffer (process-get process 'command-buf) + (when magit-blame-mode + (let ((default-directory (magit-toplevel))) + (apply #'magit-blame-run-process + (process-get process 'arguments))))))) + +(defun magit-blame-process-sentinel (process _event &optional quiet) + (let ((status (process-status process))) + (when (memq status '(exit signal)) + (kill-buffer (process-buffer process)) + (kill-buffer (process-get process 'stderr-buf)) + (if (and (eq status 'exit) + (zerop (process-exit-status process))) + (unless quiet + (message "Blaming...done")) + (magit-blame-assert-buffer process) + (with-current-buffer (process-get process 'command-buf) + (if magit-blame-mode + (progn (magit-blame-mode -1) + (message "Blaming...failed")) + (message "Blaming...aborted")))) + (kill-local-variable 'magit-blame-process)))) + +(defun magit-blame-process-filter (process string) + (internal-default-process-filter process string) + (let ((buf (process-get process 'command-buf)) + (pos (process-get process 'parsed)) + (mark (process-mark process)) + type cache) + (with-current-buffer buf + (setq type magit-blame-type) + (setq cache magit-blame-cache)) + (with-current-buffer (process-buffer process) + (goto-char pos) + (while (and (< (point) mark) + (save-excursion (re-search-forward "^filename .+\n" nil t))) + (pcase-let* ((`(,chunk ,revinfo) + (magit-blame--parse-chunk type)) + (rev (oref chunk orig-rev))) + (if revinfo + (puthash rev revinfo cache) + (setq revinfo + (or (gethash rev cache) + (puthash rev (magit-blame--commit-alist rev) cache)))) + (magit-blame--make-overlays buf chunk revinfo)) + (process-put process 'parsed (point)))))) + +(defun magit-blame--parse-chunk (type) + (let (chunk revinfo) + (unless (looking-at "^\\(.\\{40,\\}\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\)") + (error "Blaming failed due to unexpected output: %s" + (buffer-substring-no-properties (point) (line-end-position)))) + (with-slots (orig-rev orig-file prev-rev prev-file) + (setq chunk (magit-blame-chunk + :orig-rev (match-string 1) + :orig-line (string-to-number (match-string 2)) + :final-line (string-to-number (match-string 3)) + :num-lines (string-to-number (match-string 4)))) + (forward-line) + (let (done) + (while (not done) + (cond ((looking-at "^filename \\(.+\\)") + (setq done t) + (setf orig-file (magit-decode-git-path (match-string 1)))) + ((looking-at "^previous \\(.\\{40,\\}\\) \\(.+\\)") + (setf prev-rev (match-string 1)) + (setf prev-file (magit-decode-git-path (match-string 2)))) + ((looking-at "^\\([^ ]+\\) \\(.+\\)") + (push (cons (match-string 1) + (match-string 2)) + revinfo))) + (forward-line))) + (when (and (eq type 'removal) prev-rev) + (cl-rotatef orig-rev prev-rev) + (cl-rotatef orig-file prev-file) + (setq revinfo nil))) + (list chunk revinfo))) + +(defun magit-blame--commit-alist (rev) + (cl-mapcar 'cons + '("summary" + "author" "author-time" "author-tz" + "committer" "committer-time" "committer-tz") + (split-string (magit-rev-format "%s\v%an\v%ad\v%cn\v%cd" rev + "--date=format:%s\v%z") + "\v"))) + +(defun magit-blame-assert-buffer (process) + (unless (buffer-live-p (process-get process 'command-buf)) + (kill-process process) + (user-error "Buffer being blamed has been killed"))) + +;;; Display + +(defvar-local magit-blame--previous-margin-width nil) + +(defsubst magit-blame--style-get (key) + (cdr (assoc key (cdr magit-blame--style)))) + +(defun magit-blame--make-overlays (buf chunk revinfo) + (with-current-buffer buf + (save-excursion + (save-restriction + (widen) + (let* ((line (oref chunk final-line)) + (beg (magit-blame--line-beginning-position line)) + (end (magit-blame--line-beginning-position + (+ line (oref chunk num-lines)))) + (before (magit-blame-chunk-at (1- beg)))) + (when (and before + (equal (oref before orig-rev) + (oref chunk orig-rev))) + (setq beg (magit-blame--line-beginning-position + (oset chunk final-line (oref before final-line)))) + (cl-incf (oref chunk num-lines) + (oref before num-lines))) + (magit-blame--remove-overlays beg end) + (when magit-blame--make-margin-overlays + (magit-blame--make-margin-overlays chunk revinfo beg end)) + (magit-blame--make-heading-overlay chunk revinfo beg end) + (magit-blame--make-highlight-overlay chunk beg)))))) + +(defun magit-blame--line-beginning-position (line) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (point))) + +(defun magit-blame--make-margin-overlays (chunk revinfo beg end) + (save-excursion + (let ((line 0)) + (goto-char beg) + (while (< (point) end) + (magit-blame--make-margin-overlay chunk revinfo line) + (forward-line) + (cl-incf line))))) + +(defun magit-blame--make-margin-overlay (chunk revinfo line) + (let* ((end (line-end-position)) + ;; If possible avoid putting this on the first character + ;; of the line to avoid a conflict with the line overlay. + (beg (min (1+ (line-beginning-position)) end)) + (ov (make-overlay beg end))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-revinfo revinfo) + (overlay-put ov 'magit-blame-margin line) + (magit-blame--update-margin-overlay ov))) + +(defun magit-blame--make-heading-overlay (chunk revinfo beg end) + (let ((ov (make-overlay beg end))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-revinfo revinfo) + (overlay-put ov 'magit-blame-heading t) + (magit-blame--update-heading-overlay ov))) + +(defun magit-blame--make-highlight-overlay (chunk beg) + (let ((ov (make-overlay beg (1+ (magit--eol-position beg))))) + (overlay-put ov 'magit-blame-chunk chunk) + (overlay-put ov 'magit-blame-highlight t) + (magit-blame--update-highlight-overlay ov))) + +(defun magit-blame--update-margin (&optional action) + (when (eq action 'enable) + (setq magit-blame--previous-margin-width left-margin-width)) + (setq left-margin-width + (if (eq action 'disable) + (prog1 magit-blame--previous-margin-width + (setq magit-blame--previous-margin-width nil)) + (or (magit-blame--style-get 'margin-width) + magit-blame--previous-margin-width))) + (set-window-buffer (selected-window) (current-buffer))) + +(defun magit-blame--update-overlays () + (save-restriction + (widen) + (dolist (ov (overlays-in (point-min) (point-max))) + (cond ((overlay-get ov 'magit-blame-heading) + (magit-blame--update-heading-overlay ov)) + ((overlay-get ov 'magit-blame-margin) + (magit-blame--update-margin-overlay ov)) + ((overlay-get ov 'magit-blame-highlight) + (magit-blame--update-highlight-overlay ov)))))) + +(defun magit-blame--update-margin-overlay (ov) + (overlay-put + ov 'before-string + (and (magit-blame--style-get 'margin-width) + (propertize + "o" 'display + (list (list 'margin 'left-margin) + (let ((line (overlay-get ov 'magit-blame-margin)) + (format (magit-blame--style-get 'margin-format)) + (face (magit-blame--style-get 'margin-face))) + (magit-blame--format-string + ov + (or (and (atom format) + format) + (nth line format) + (car (last format))) + (or (and (not (zerop line)) + (magit-blame--style-get 'margin-body-face)) + face + 'magit-blame-margin)))))))) + +(defun magit-blame--update-heading-overlay (ov) + (overlay-put + ov 'before-string + (if-let ((format (magit-blame--style-get 'heading-format))) + ;; Use `default' as the last face to avoid picking up any face + ;; attributes from the first character of the text on which we + ;; put the overlay. See #5233. + (magit-blame--format-string ov format '(magit-blame-heading default)) + (and (magit-blame--style-get 'show-lines) + (or (not (magit-blame--style-get 'margin-format)) + (save-excursion + (goto-char (overlay-start ov)) + ;; Special case of the special case described in + ;; `magit-blame--make-margin-overlay'. For empty + ;; lines it is not possible to show both overlays + ;; without the line being too high. + (not (= (point) (line-end-position))))) + magit-blame-separator)))) + +(defun magit-blame--update-highlight-overlay (ov) + (overlay-put ov 'font-lock-face (magit-blame--style-get 'highlight-face))) + +(defun magit-blame--format-string (ov format face) + (let* ((chunk (overlay-get ov 'magit-blame-chunk)) + (revinfo (overlay-get ov 'magit-blame-revinfo)) + (key (list format face)) + (string (cdr (assoc key revinfo)))) + (unless string + (setq string + (and format + (magit-blame--format-string-1 (oref chunk orig-rev) + revinfo format face))) + (nconc revinfo (list (cons key string)))) + string)) + +(defun magit-blame--format-string-1 (rev revinfo format face) + (let ((str + (if (string-match-p "\\`0\\{40,\\}\\'" rev) + (propertize (concat (if (string-prefix-p "\s" format) "\s" "") + "Not Yet Committed" + (if (string-suffix-p "\n" format) "\n" "")) + 'font-lock-face face) + (magit--format-spec + (propertize format 'font-lock-face face) + (cl-flet* ((p0 (s f) + (propertize s 'font-lock-face + (if face (cons f (ensure-list face)) f))) + (p1 (k f) + (p0 (cdr (assoc k revinfo)) f)) + (p2 (k1 k2 f) + (p0 (magit-blame--format-time-string + (cdr (assoc k1 revinfo)) + (cdr (assoc k2 revinfo))) + f))) + `((?H . ,(p0 rev 'magit-blame-hash)) + (?h . ,(p0 (magit-blame--abbrev-hash rev) 'magit-blame-hash)) + (?s . ,(p1 "summary" 'magit-blame-summary)) + (?a . ,(p1 "author" 'magit-blame-name)) + (?c . ,(p1 "committer" 'magit-blame-name)) + (?A . ,(p2 "author-time" "author-tz" 'magit-blame-date)) + (?C . ,(p2 "committer-time" "committer-tz" 'magit-blame-date)) + (?f . ""))))))) + (if-let ((width (and (string-suffix-p "%f" format) + (magit-blame--style-get 'margin-width)))) + (concat str + (propertize (make-string (max 0 (- width (length str))) ?\s) + 'font-lock-face face)) + str))) + +(defun magit-blame--format-separator () + (propertize (concat (propertize "\s" 'display '(space :height (2))) + (propertize "\n" 'line-height t)) + 'font-lock-face + `( :extend t + :background + ,(face-attribute 'magit-blame-heading :background nil t)))) + +(defun magit-blame--format-time-string (time tz) + (let* ((time-format (or (magit-blame--style-get 'time-format) + magit-blame-time-format)) + (tz-in-second (and (string-search "%z" time-format) + (car (last (parse-time-string tz)))))) + (format-time-string time-format + (seconds-to-time (string-to-number time)) + tz-in-second))) + +(defvar-local magit-blame--abbrev-length nil) + +(defun magit-blame--abbrev-hash (rev) + (substring rev 0 (or magit-blame--abbrev-length + (setq magit-blame--abbrev-length + (magit-abbrev-length))))) + +(defun magit-blame--remove-overlays (&optional beg end) + (save-restriction + (widen) + (dolist (ov (overlays-in (or beg (point-min)) + (or end (point-max)))) + (when (overlay-get ov 'magit-blame-chunk) + (delete-overlay ov))))) + +(defun magit-blame-maybe-show-message () + (when (magit-blame--style-get 'show-message) + (if-let ((msg (cdr (assoc "summary" + (gethash (oref (magit-current-blame-chunk) + orig-rev) + magit-blame-cache))))) + (progn (set-text-properties 0 (length msg) nil msg) + (magit-msg "%S" msg)) + (magit-msg "Commit data not available yet. Still blaming.")))) + +;;; Commands + +;;;###autoload (autoload 'magit-blame-echo "magit-blame" nil t) +(transient-define-suffix magit-blame-echo (args) + "For each line show the revision in which it was added. +Show the information about the chunk at point in the echo area +when moving between chunks. Unlike other blaming commands, do +not turn on `read-only-mode'." + :if (##and buffer-file-name + (or (not magit-blame-mode) + buffer-read-only)) + (interactive (list (magit-blame-arguments))) + (when magit-buffer-file-name + (user-error "Blob buffers aren't supported")) + (setq-local magit-blame--style + (assq magit-blame-echo-style magit-blame-styles)) + (setq-local magit-blame-disable-modes + (cons 'eldoc-mode magit-blame-disable-modes)) + (if (not magit-blame-mode) + (let ((magit-blame-read-only nil)) + (magit-blame--pre-blame-assert 'addition) + (magit-blame--pre-blame-setup 'addition) + (magit-blame--run args)) + (read-only-mode -1) + (magit-blame--update-overlays))) + +;;;###autoload (autoload 'magit-blame-addition "magit-blame" nil t) +(transient-define-suffix magit-blame-addition (args) + "For each line show the revision in which it was added." + (interactive (list (magit-blame-arguments))) + (magit-blame--pre-blame-assert 'addition) + (magit-blame--pre-blame-setup 'addition) + (magit-blame--run args)) + +;;;###autoload (autoload 'magit-blame-removal "magit-blame" nil t) +(transient-define-suffix magit-blame-removal (args) + "For each line show the revision in which it was removed." + :if-nil 'buffer-file-name + (interactive (list (magit-blame-arguments))) + (unless magit-buffer-file-name + (user-error "Only blob buffers can be blamed in reverse")) + (magit-blame--pre-blame-assert 'removal) + (magit-blame--pre-blame-setup 'removal) + (magit-blame--run args)) + +;;;###autoload (autoload 'magit-blame-reverse "magit-blame" nil t) +(transient-define-suffix magit-blame-reverse (args) + "For each line show the last revision in which it still exists." + :if-nil 'buffer-file-name + (interactive (list (magit-blame-arguments))) + (unless magit-buffer-file-name + (user-error "Only blob buffers can be blamed in reverse")) + (magit-blame--pre-blame-assert 'final) + (magit-blame--pre-blame-setup 'final) + (magit-blame--run args)) + +(defun magit-blame--pre-blame-assert (type) + (unless (magit-toplevel) + (magit--not-inside-repository-error)) + (if (and magit-blame-mode + (eq type magit-blame-type)) + (if-let ((chunk (magit-current-blame-chunk))) + (unless (oref chunk prev-rev) + (user-error "Chunk has no further history")) + (user-error "Still blaming, commit data not available yet")) + (unless (magit-file-relative-name nil (not magit-buffer-file-name)) + (if buffer-file-name + (user-error "Buffer isn't visiting a tracked file") + (user-error "Buffer isn't visiting a file"))))) + +(defun magit-blame--pre-blame-setup (type) + (when magit-blame-mode + (if (eq type magit-blame-type) + (let ((style magit-blame--style)) + (magit-blame-visit-other-file) + (setq-local magit-blame--style style) + (setq-local magit-blame-recursive-p t) + ;; Set window-start for the benefit of quickstart. + (redisplay)) + (magit-blame--remove-overlays))) + (setq magit-blame-type type)) + +(defun magit-blame-visit-other-file () + "Visit another blob related to the current chunk." + (interactive) + (with-slots (prev-rev prev-file orig-line) + (magit-current-blame-chunk) + (unless prev-rev + (user-error "Chunk has no further history")) + (magit-with-toplevel + (magit-find-file prev-rev prev-file)) + ;; TODO Adjust line like magit-diff-visit-file. + (goto-char (point-min)) + (forward-line (1- orig-line)))) + +(defun magit-blame-visit-file () + "Visit the blob related to the current chunk." + (interactive) + (with-slots (orig-rev orig-file orig-line) + (magit-current-blame-chunk) + (magit-with-toplevel + (magit-find-file orig-rev orig-file)) + (goto-char (point-min)) + (forward-line (1- orig-line)))) + +(transient-define-suffix magit-blame-quit () + "Turn off Magit-Blame mode. +If the buffer was created during a recursive blame, +then also kill the buffer." + :if-non-nil 'magit-blame-mode + (interactive) + (magit-blame-mode -1) + (when magit-blame-recursive-p + (kill-buffer))) + +(defun magit-blame-next-chunk () + "Move to the next chunk." + (interactive) + (if-let ((next (next-single-char-property-change + (point) 'magit-blame-chunk))) + (goto-char next) + (user-error "No more chunks"))) + +(defun magit-blame-previous-chunk () + "Move to the previous chunk." + (interactive) + (if-let ((prev (previous-single-char-property-change + (point) 'magit-blame-chunk))) + (goto-char prev) + (user-error "No more chunks"))) + +(defun magit-blame-next-chunk-same-commit (&optional previous) + "Move to the next chunk from the same commit. +\n(fn)" + (interactive) + (if-let ((rev (oref (magit-current-blame-chunk) orig-rev))) + (let ((pos (point)) ov) + (save-excursion + (while (and (not ov) + (not (= pos (if previous (point-min) (point-max)))) + (setq pos (funcall + (if previous + #'previous-single-char-property-change + #'next-single-char-property-change) + pos 'magit-blame-chunk))) + (when-let ((o (magit-blame--overlay-at pos)) + ((equal (oref (magit-blame-chunk-at pos) orig-rev) rev))) + (setq ov o)))) + (if ov + (goto-char (overlay-start ov)) + (user-error "No more chunks from same commit"))) + (user-error "This chunk hasn't been blamed yet"))) + +(defun magit-blame-previous-chunk-same-commit () + "Move to the previous chunk from the same commit." + (interactive) + (magit-blame-next-chunk-same-commit #'previous-single-char-property-change)) + +(defun magit-blame-cycle-style () + "Change how blame information is visualized. +Cycle through the elements of option `magit-blame-styles'." + (interactive) + (setq magit-blame--style + (or (cadr (cl-member (car magit-blame--style) + magit-blame-styles :key #'car)) + (car magit-blame-styles))) + (magit-blame--update-margin) + (magit-blame--update-overlays)) + +(defun magit-blame-copy-hash () + "Save hash of the current chunk's commit to the kill ring. + +When the region is active, then save the region's content +instead of the hash, like `kill-ring-save' would." + (interactive) + (if (use-region-p) + (call-interactively #'copy-region-as-kill) + (kill-new (message "%s" (oref (magit-current-blame-chunk) orig-rev))))) + +;;; Popup + +;;;###autoload (autoload 'magit-blame "magit-blame" nil t) +(transient-define-prefix magit-blame () + "Show the commits that added or removed lines in the visited file." + :man-page "git-blame" + :value '("-w") + ["Arguments" + ("-w" "Ignore whitespace" "-w") + ("-r" "Do not treat root commits as boundaries" "--root") + ("-P" "Follow only first parent" "--first-parent") + (magit-blame:-M) + (magit-blame:-C)] + ["Actions" + ("b" "Show commits adding lines" magit-blame-addition) + ("r" "Show commits removing lines" magit-blame-removal) + ("f" "Show last commits that still have lines" magit-blame-reverse) + ("m" "Blame echo" magit-blame-echo) + ("q" "Quit blaming" magit-blame-quit)] + ["Refresh" + :if-non-nil magit-blame-mode + ("c" "Cycle style" magit-blame-cycle-style :transient t)]) + +(defun magit-blame-arguments () + (transient-args 'magit-blame)) + +(transient-define-argument magit-blame:-M () + :description "Detect lines moved or copied within a file" + :class 'transient-option + :argument "-M" + :allow-empty t + :reader #'transient-read-number-N+) + +(transient-define-argument magit-blame:-C () + :description "Detect lines moved or copied between files" + :class 'transient-option + :argument "-C" + :allow-empty t + :reader #'transient-read-number-N+) + +;;; Utilities + +(defun magit-blame-maybe-update-revision-buffer () + (when-let* ((chunk (magit-current-blame-chunk)) + (commit (oref chunk orig-rev)) + (buffer (magit-get-mode-buffer 'magit-revision-mode nil t))) + (if magit--update-revision-buffer + (setq magit--update-revision-buffer (list commit buffer)) + (setq magit--update-revision-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-revision-buffer)) + (setq magit--update-revision-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-show-commit rev + (magit-diff-arguments 'magit-revision-mode)))))))))) + +;;; _ +(provide 'magit-blame) +;;; magit-blame.el ends here blob - /dev/null blob + bbb1215156275fc3b62f486d8415edd2dd83900c (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-bookmark.el @@ -0,0 +1,159 @@ +;;; magit-bookmark.el --- Bookmarks for Magit buffers -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Inspired by an earlier implementation by Yuri Khan. + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Support for bookmarks for most Magit buffers. + +;;; Code: + +(require 'magit) + +(require 'bookmark) + +;;; Common + +(cl-defmethod magit-bookmark-get-filename (&context (major-mode magit-mode)) + (magit-toplevel)) + +(cl-defmethod magit-bookmark-get-value + (bookmark &context (major-mode magit-mode)) + (dolist (var (get major-mode 'magit-bookmark-variables)) + (bookmark-prop-set bookmark var (symbol-value var)))) + +(cl-defmethod magit-bookmark-get-buffer-create + (bookmark (mode (derived-mode magit-mode))) + (let ((default-directory (bookmark-get-filename bookmark)) + (magit-display-buffer-function #'identity) + (magit-display-buffer-noselect t)) + (apply (intern (format "%s-setup-buffer" + (substring (symbol-name mode) 0 -5))) + (mapcar (##bookmark-prop-get bookmark %) + (get mode 'magit-bookmark-variables))))) + +;;; Diff +;;;; Diff + +(put 'magit-diff-mode 'magit-bookmark-variables + '(magit-buffer-range-hashed + magit-buffer-typearg + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-diff-mode)) + (format "magit-diff(%s%s)" + (pcase (magit-diff-type) + ('staged "staged") + ('unstaged "unstaged") + ('committed magit-buffer-range) + ('undefined + (delq nil (list magit-buffer-typearg magit-buffer-range-hashed)))) + (if magit-buffer-diff-files + (concat " -- " (string-join magit-buffer-diff-files " ")) + ""))) + +;;;; Revision + +(put 'magit-revision-mode 'magit-bookmark-variables + '(magit-buffer-revision-hash + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-revision-mode)) + (format "magit-revision(%s %s)" + (magit-rev-abbrev magit-buffer-revision) + (if magit-buffer-diff-files + (string-join magit-buffer-diff-files " ") + (magit-rev-format "%s" magit-buffer-revision)))) + +;;;; Stash + +(put 'magit-stash-mode 'magit-bookmark-variables + '(magit-buffer-revision-hash + magit-buffer-diff-args + magit-buffer-diff-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-stash-mode)) + (format "magit-stash(%s %s)" + (magit-rev-abbrev magit-buffer-revision) + (if magit-buffer-diff-files + (string-join magit-buffer-diff-files " ") + (magit-rev-format "%s" magit-buffer-revision)))) + +(cl-defmethod magit-bookmark--get-child-value + (section &context (major-mode magit-stash-mode)) + (string-replace magit-buffer-revision + magit-buffer-revision-hash + (oref section value))) + +;;; Log +;;;; Log + +(put 'magit-log-mode 'magit-bookmark-variables + '(magit-buffer-revisions + magit-buffer-log-args + magit-buffer-log-files)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-log-mode)) + (format "magit-log(%s%s)" + (string-join magit-buffer-revisions " ") + (if magit-buffer-log-files + (concat " -- " (string-join magit-buffer-log-files " ")) + ""))) + +;;;; Cherry + +(put 'magit-cherry-mode 'magit-bookmark-variables + '(magit-buffer-refname + magit-buffer-upstream)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-cherry-mode)) + (format "magit-cherry(%s > %s)" + magit-buffer-refname + magit-buffer-upstream)) + +;;;; Reflog + +(put 'magit-reflog-mode 'magit-bookmark-variables + '(magit-buffer-refname)) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-reflog-mode)) + (format "magit-reflog(%s)" magit-buffer-refname)) + +;;; Misc + +(put 'magit-status-mode 'magit-bookmark-variables nil) + +(put 'magit-refs-mode 'magit-bookmark-variables + '(magit-buffer-upstream + magit-buffer-arguments)) + +(put 'magit-stashes-mode 'magit-bookmark-variables nil) + +(cl-defmethod magit-bookmark-name (&context (major-mode magit-stashes-mode)) + (format "magit-states(%s)" magit-buffer-refname)) + +;;; _ +(provide 'magit-bookmark) +;;; magit-bookmark.el ends here blob - /dev/null blob + 56a754e571aa73da1839eb12e7cb822be3fb0e33 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-branch.el @@ -0,0 +1,982 @@ +;;; magit-branch.el --- Branch support -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for branches. It defines commands +;; for creating, checking out, manipulating, and configuring branches. +;; Commands defined here are mainly concerned with branches as +;; pointers, commands that deal with what a branch points at, are +;; defined elsewhere. + +;;; Code: + +(require 'magit) +(require 'magit-reset) + +;;; Options + +(defcustom magit-branch-read-upstream-first t + "Whether to read upstream before name of new branch when creating a branch. + +`nil' Read the branch name first. +`t' Read the upstream first. +`fallback' Read the upstream first, but if it turns out that the chosen + value is not a valid upstream (because it cannot be resolved + as an existing revision), then treat it as the name of the + new branch and continue by reading the upstream next." + :package-version '(magit . "2.2.0") + :group 'magit-commands + :type '(choice (const :tag "Read branch name first" nil) + (const :tag "Read upstream first" t) + (const :tag "Read upstream first, with fallback" fallback))) + +(defcustom magit-branch-prefer-remote-upstream nil + "Whether to favor remote upstreams when creating new branches. + +When a new branch is created, then the branch, commit, or stash +at point is suggested as the default starting point of the new +branch, or if there is no such revision at point the current +branch. In either case the user may choose another starting +point. + +If the chosen starting point is a branch, then it may also be set +as the upstream of the new branch, depending on the value of the +Git variable `branch.autoSetupMerge'. By default this is done +for remote branches, but not for local branches. + +You might prefer to always use some remote branch as upstream. +If the chosen starting point is (1) a local branch, (2) whose +name matches a member of the value of this option, (3) the +upstream of that local branch is a remote branch with the same +name, and (4) that remote branch can be fast-forwarded to the +local branch, then the chosen branch is used as starting point, +but its own upstream is used as the upstream of the new branch. + +Members of this option's value are treated as branch names that +have to match exactly unless they contain a character that makes +them invalid as a branch name. Recommended characters to use +to trigger interpretation as a regexp are \"*\" and \"^\". Some +other characters which you might expect to be invalid, actually +are not, e.g., \".+$\" are all perfectly valid. More precisely, +if `git check-ref-format --branch STRING' exits with a non-zero +status, then treat STRING as a regexp. + +Assuming the chosen branch matches these conditions you would end +up with with e.g.: + + feature --upstream--> origin/master + +instead of + + feature --upstream--> master --upstream--> origin/master + +Which you prefer is a matter of personal preference. If you do +prefer the former, then you should add branches such as \"master\", +\"next\", and \"maint\" to the value of this options." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(repeat string)) + +(defcustom magit-branch-adjust-remote-upstream-alist nil + "Alist of upstreams to be used when branching from remote branches. + +When creating a local branch from an ephemeral branch located +on a remote, e.g., a feature or hotfix branch, then that remote +branch should usually not be used as the upstream branch, since +the push-remote already allows accessing it and having both the +upstream and the push-remote reference the same related branch +would be wasteful. Instead a branch like \"maint\" or \"master\" +should be used as the upstream. + +This option allows specifying the branch that should be used as +the upstream when branching certain remote branches. The value +is an alist of the form ((UPSTREAM . RULE)...). The first +element is used whose UPSTREAM exists and whose RULE matches +the name of the new branch. Subsequent elements are ignored. + +UPSTREAM is the branch to be used as the upstream for branches +specified by RULE. It can be a local or a remote branch. + +RULE can either be a regular expression, matching branches whose +upstream should be the one specified by UPSTREAM. Or it can be +a list of the only branches that should *not* use UPSTREAM; all +other branches will. Matching is done after stripping the remote +part of the name of the branch that is being branched from. + +If you use a finite set of non-ephemeral branches across all your +repositories, then you might use something like: + + ((\"origin/master\" . (\"master\" \"next\" \"maint\"))) + +Or if the names of all your ephemeral branches contain a slash, +at least in some repositories, then a good value could be: + + ((\"origin/master\" . \"/\")) + +Of course you can also fine-tune: + + ((\"origin/maint\" . \"\\\\\\=`hotfix/\") + (\"origin/master\" . \"\\\\\\=`feature/\")) + +UPSTREAM can be a local branch: + + ((\"master\" . (\"master\" \"next\" \"maint\"))) + +Because the main branch is no longer almost always named \"master\" +you should also account for other common names: + + ((\"main\" . (\"main\" \"master\" \"next\" \"maint\")) + (\"master\" . (\"main\" \"master\" \"next\" \"maint\"))) + +If you use remote branches as UPSTREAM, then you might also want +to set `magit-branch-prefer-remote-upstream' to a non-nil value. +However, I recommend that you use local branches as UPSTREAM." + :package-version '(magit . "2.9.0") + :group 'magit-commands + :type '(repeat (cons (string :tag "Use upstream") + (choice :tag "For branches" ;??? + (regexp :tag "Matching") + (repeat :tag "Except" + (string :tag "Branch")))))) + +(defcustom magit-branch-rename-push-target t + "Whether the push-remote setup is preserved when renaming a branch. + +The command `magit-branch-rename' renames a branch named OLD to +NEW. This option controls how much of the push-remote setup is +preserved when doing so. + +When nil, then preserve nothing and unset `branch.OLD.pushRemote'. + +When `local-only', then first set `branch.NEW.pushRemote' to the + same value as `branch.OLD.pushRemote', provided the latter is + actually set and unless the former already has another value. + +When t, then rename the branch named OLD on the remote specified + by `branch.OLD.pushRemote' to NEW, provided OLD exists on that + remote and unless NEW already exists on the remote. + +When `forge-only' and the `forge' package is available, then + behave like `t' if the remote points to a repository on a forge + (currently Github or Gitlab), otherwise like `local-only'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type '(choice + (const :tag "Don't preserve push-remote setup" nil) + (const :tag "Preserve push-remote setup" local-only) + (const :tag "... and rename corresponding branch on remote" t) + (const :tag "... but only if remote is on a forge" forge-only))) + +(defcustom magit-branch-direct-configure t + "Whether the command `magit-branch' shows Git variables. +When set to nil, no variables are displayed by this transient +command, instead the sub-transient `magit-branch-configure' +has to be used to view and change branch related variables." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-published-branches '("origin/master") + "List of branches that are considered to be published." + :package-version '(magit . "2.13.0") + :group 'magit-commands + :type '(repeat string)) + +;;; Commands + +;;;###autoload (autoload 'magit-branch "magit" nil t) +(transient-define-prefix magit-branch (branch) + "Add, configure or remove a branch." + :man-page "git-branch" + [:if (##and magit-branch-direct-configure (transient-scope)) + :description (##concat + (propertize "Configure " 'face 'transient-heading) + (propertize (transient-scope) 'face 'magit-branch-local)) + ("d" magit-branch..description) + ("u" magit-branch..merge/remote) + ("r" magit-branch..rebase) + ("p" magit-branch..pushRemote)] + [:if-non-nil magit-branch-direct-configure + :description "Configure repository defaults" + ("R" magit-pull.rebase) + ("P" magit-remote.pushDefault) + ("B" "Update default branch" magit-update-default-branch + :inapt-if-not magit-get-some-remote)] + ["Arguments" + (7 "-r" "Recurse submodules when checking out an existing branch" + "--recurse-submodules")] + [["Checkout" + ("b" "branch/revision" magit-checkout) + ("l" "local branch" magit-branch-checkout) + (6 "o" "new orphan" magit-branch-orphan)] + ["" + ("c" "new branch" magit-branch-and-checkout) + ("s" "new spin-off" magit-branch-spinoff) + (5 "w" "new worktree" magit-worktree-checkout)] + ["Create" + ("n" "new branch" magit-branch-create) + ("S" "new spin-out" magit-branch-spinout) + (5 "W" "new worktree" magit-worktree-branch)] + ["Do" + ("C" "configure..." magit-branch-configure) + ("m" "rename" magit-branch-rename) + ("x" "reset" magit-branch-reset) + ("k" "delete" magit-branch-delete)] + ["" + (7 "h" "shelve" magit-branch-shelve) + (7 "H" "unshelve" magit-branch-unshelve)]] + (interactive (list (magit-get-current-branch))) + (transient-setup 'magit-branch nil nil :scope branch)) + +(defun magit-branch-arguments () + (transient-args 'magit-branch)) + +;;;###autoload +(defun magit-checkout (revision &optional args) + "Checkout REVISION, updating the index and the working tree. +If REVISION is a local branch, then that becomes the current +branch. If it is something else, then `HEAD' becomes detached. +Checkout fails if the working tree or the staging area contain +changes. +\n(git checkout REVISION)." + (declare (interactive-only magit--checkout)) + (interactive (list (magit-read-other-branch-or-commit "Checkout") + (magit-branch-arguments))) + (when (string-match "\\`heads/\\(.+\\)" revision) + (setq revision (match-string 1 revision))) + (magit-run-git-async "checkout" args revision)) + +(defun magit--checkout (revision &optional args) + (when (string-match "\\`heads/\\(.+\\)" revision) + (setq revision (match-string 1 revision))) + (magit-call-git "checkout" args revision)) + +;;;###autoload +(defun magit-branch-create (branch start-point) + "Create BRANCH at branch or revision START-POINT." + (declare (interactive-only magit-call-git)) + (interactive (magit-branch-read-args "Create branch")) + (magit-run-git-async "branch" branch start-point) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (magit-branch-maybe-adjust-upstream branch start-point) + (magit-process-sentinel process event))))) + +;;;###autoload +(defun magit-branch-and-checkout (branch start-point &optional args) + "Create and checkout BRANCH at branch or revision START-POINT." + (declare (interactive-only magit-call-git)) + (interactive (append (magit-branch-read-args "Create and checkout branch") + (list (magit-branch-arguments)))) + (if (string-match-p "^stash@{[0-9]+}$" start-point) + (magit-run-git "stash" "branch" branch start-point) + (magit-run-git-async "checkout" args "-b" branch start-point) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (magit-branch-maybe-adjust-upstream branch start-point) + (magit-process-sentinel process event)))))) + +;;;###autoload +(defun magit-branch-or-checkout (arg &optional start-point) + "Hybrid between `magit-checkout' and `magit-branch-and-checkout'. + +Ask the user for an existing branch or revision. If the user +input actually can be resolved as a branch or revision, then +check that out, just like `magit-checkout' would. + +Otherwise create and checkout a new branch using the input as +its name. Before doing so read the starting-point for the new +branch. This is similar to what `magit-branch-and-checkout' +does." + (declare (interactive-only magit-call-git)) + (interactive + (let ((arg (magit-read-other-branch-or-commit "Checkout"))) + (list arg + (and (not (magit-commit-p arg)) + (magit-read-starting-point "Create and checkout branch" arg))))) + (when (string-match "\\`heads/\\(.+\\)" arg) + (setq arg (match-string 1 arg))) + (if start-point + (with-suppressed-warnings ((interactive-only magit-branch-and-checkout)) + (magit-branch-and-checkout arg start-point)) + (magit--checkout arg) + (magit-refresh))) + +;;;###autoload +(defun magit-branch-checkout (branch &optional start-point) + "Checkout an existing or new local branch. + +Read a branch name from the user offering all local branches and +a subset of remote branches as candidates. Omit remote branches +for which a local branch by the same name exists from the list +of candidates. The user can also enter a completely new branch +name. + +- If the user selects an existing local branch, then check that + out. + +- If the user selects a remote branch, then create and checkout + a new local branch with the same name. Configure the selected + remote branch as push target. + +- If the user enters a new branch name, then create and check + that out, after also reading the starting-point from the user. + +In the latter two cases the upstream is also set. Whether it is +set to the chosen START-POINT or something else depends on the +value of `magit-branch-adjust-remote-upstream-alist', just like +when using `magit-branch-and-checkout'." + (declare (interactive-only magit-call-git)) + (interactive + (let* ((current (magit-get-current-branch)) + (local (magit-list-local-branch-names)) + (remote (seq-filter (##and (string-match "[^/]+/" %) + (not (member (substring % (match-end 0)) + (cons "HEAD" local)))) + (magit-list-remote-branch-names))) + (choices (nconc (delete current local) remote)) + (atpoint (magit-branch-at-point)) + (choice (magit-completing-read + "Checkout branch" choices + nil nil nil 'magit-revision-history + (or (car (member atpoint choices)) + (and atpoint + (car (member (and (string-match "[^/]+/" atpoint) + (substring atpoint (match-end 0))) + choices))))))) + (cond ((member choice remote) + (list (and (string-match "[^/]+/" choice) + (substring choice (match-end 0))) + choice)) + ((member choice local) + (list choice)) + (t + (list choice (magit-read-starting-point "Create" choice)))))) + (cond + ((not start-point) + (magit--checkout branch (magit-branch-arguments)) + (magit-refresh)) + (t + (when (magit-anything-modified-p t) + (user-error "Cannot checkout when there are uncommitted changes")) + (magit-run-git-async "checkout" (magit-branch-arguments) + "-b" branch start-point) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (magit-branch-maybe-adjust-upstream branch start-point) + (when (magit-remote-branch-p start-point) + (pcase-let ((`(,remote . ,remote-branch) + (magit-split-branch-name start-point))) + (when (and (equal branch remote-branch) + (not (equal remote (magit-get "remote.pushDefault")))) + (magit-set remote "branch" branch "pushRemote")))) + (magit-process-sentinel process event))))))) + +(defun magit-branch-maybe-adjust-upstream (branch start-point) + (when-let ((upstream + (or (and (magit-get-upstream-branch branch) + (magit-get-indirect-upstream-branch start-point)) + (and (magit-remote-branch-p start-point) + (let ((name (cdr (magit-split-branch-name start-point)))) + (seq-some + (pcase-lambda (`(,upstream . ,rule)) + (and (magit-branch-p upstream) + (if (listp rule) + (not (member name rule)) + (string-match-p rule name)) + upstream)) + magit-branch-adjust-remote-upstream-alist)))))) + (magit-call-git "branch" (concat "--set-upstream-to=" upstream) branch))) + +;;;###autoload +(defun magit-branch-orphan (branch start-point) + "Create and checkout an orphan BRANCH with contents from revision START-POINT." + (interactive (magit-branch-read-args "Create and checkout orphan branch")) + (magit-run-git "checkout" "--orphan" branch start-point)) + +(defun magit-branch-read-args (prompt &optional default-start) + (if magit-branch-read-upstream-first + (let ((choice (magit-read-starting-point prompt nil default-start))) + (cond + ((magit-rev-verify choice) + (list (magit-read-string-ns + (if magit-completing-read--silent-default + (format "%s (starting at `%s')" prompt choice) + "Name for new branch") + (let ((def (string-join (cdr (split-string choice "/")) "/"))) + (and (member choice (magit-list-remote-branch-names)) + (not (member def (magit-list-local-branch-names))) + def))) + choice)) + ((eq magit-branch-read-upstream-first 'fallback) + (list choice + (magit-read-starting-point prompt choice default-start))) + ((user-error "Not a valid starting-point: %s" choice)))) + (let ((branch (magit-read-string-ns (concat prompt " named")))) + (if (magit-branch-p branch) + (magit-branch-read-args + (format "Branch `%s' already exists; pick another name" branch) + default-start) + (list branch (magit-read-starting-point prompt branch default-start)))))) + +;;;###autoload +(defun magit-branch-spinout (branch &optional from) + "Create new branch from the unpushed commits. +Like `magit-branch-spinoff' but remain on the current branch. +If there are any uncommitted changes, then behave exactly like +`magit-branch-spinoff'." + (interactive (list (magit-read-string-ns "Spin out branch") + (car (last (magit-region-values 'commit))))) + (magit--branch-spinoff branch from nil)) + +;;;###autoload +(defun magit-branch-spinoff (branch &optional from) + "Create new branch from the unpushed commits. + +Create and checkout a new branch starting at and tracking the +current branch. That branch in turn is reset to the last commit +it shares with its upstream. If the current branch has no +upstream or no unpushed commits, then the new branch is created +anyway and the previously current branch is not touched. + +This is useful to create a feature branch after work has already +began on the old branch (likely but not necessarily \"master\"). + +If the current branch is a member of the value of option +`magit-branch-prefer-remote-upstream' (which see), then the +current branch will be used as the starting point as usual, but +the upstream of the starting-point may be used as the upstream +of the new branch, instead of the starting-point itself. + +If optional FROM is non-nil, then the source branch is reset +to `FROM~', instead of to the last commit it shares with its +upstream. Interactively, FROM is only ever non-nil, if the +region selects some commits, and among those commits, FROM is +the commit that is the fewest commits ahead of the source +branch. + +The commit at the other end of the selection actually does not +matter, all commits between FROM and `HEAD' are moved to the new +branch. If FROM is not reachable from `HEAD' or is reachable +from the source branch's upstream, then an error is raised." + (interactive (list (magit-read-string-ns "Spin off branch") + (car (last (magit-region-values 'commit))))) + (magit--branch-spinoff branch from t)) + +(defun magit--branch-spinoff (branch from checkout) + (when (magit-branch-p branch) + (user-error "Cannot spin off %s. It already exists" branch)) + (when (and (not checkout) + (magit-anything-modified-p)) + (message "Staying on HEAD due to uncommitted changes") + (setq checkout t)) + (if-let ((current (magit-get-current-branch))) + (let ((tracked (magit-get-upstream-branch current)) + base) + (when from + (unless (magit-rev-ancestor-p from current) + (user-error "Cannot spin off %s. %s is not reachable from %s" + branch from current)) + (when (and tracked + (magit-rev-ancestor-p from tracked)) + (user-error "Cannot spin off %s. %s is ancestor of upstream %s" + branch from tracked))) + (let ((magit-process-raise-error t)) + (if checkout + (magit-call-git "checkout" "-b" branch current) + (magit-call-git "branch" branch current))) + (when-let ((upstream (magit-get-indirect-upstream-branch current))) + (magit-call-git "branch" "--set-upstream-to" upstream branch)) + (when (and tracked + (setq base + (if from + (concat from "^") + (magit-git-string "merge-base" current tracked))) + (not (magit-rev-eq base current))) + (if checkout + (magit-call-git "update-ref" "-m" + (format "reset: moving to %s" base) + (concat "refs/heads/" current) base) + (magit-call-git "reset" "--hard" base)))) + (if checkout + (magit-call-git "checkout" "-b" branch) + (magit-call-git "branch" branch))) + (magit-refresh)) + +;;;###autoload +(defun magit-branch-reset (branch to &optional set-upstream) + "Reset a branch to the tip of another branch or any other commit. + +When the branch being reset is the current branch, then do a +hard reset. If there are any uncommitted changes, then the user +has to confirm the reset because those changes would be lost. + +This is useful when you have started work on a feature branch but +realize it's all crap and want to start over. + +When resetting to another branch and a prefix argument is used, +then also set the target branch as the upstream of the branch +that is being reset." + (interactive + (let ((branch (magit-read-local-branch "Reset branch" + (magit-local-branch-at-point)))) + (list branch + (magit-read-branch-or-commit (format "Reset %s to" branch) + (magit-get-upstream-branch branch) + branch) + current-prefix-arg))) + (let ((magit-inhibit-refresh t)) + (if (equal branch (magit-get-current-branch)) + (if (and (magit-anything-modified-p) + (not (yes-or-no-p + "Uncommitted changes will be lost. Proceed? "))) + (user-error "Abort") + (magit-reset-hard to)) + (magit-call-git "update-ref" + "-m" (format "reset: moving to %s" to) + (magit-git-string "rev-parse" "--symbolic-full-name" + branch) + to)) + (when (and set-upstream (magit-branch-p to)) + (magit-set-upstream-branch branch to) + (magit-branch-maybe-adjust-upstream branch to))) + (magit-refresh)) + +(defvar magit-branch-delete-never-verify nil + "Whether `magit-branch-delete' always pushes with \"--no-verify\".") + +;;;###autoload +(defun magit-branch-delete (branches &optional force) + "Delete one or multiple branches. + +If the region marks multiple branches, then offer to delete +those, otherwise prompt for a single branch to be deleted, +defaulting to the branch at point. + +Require confirmation when deleting branches is dangerous in some +way. Option `magit-no-confirm' can be customized to not require +confirmation in certain cases. See its docstring to learn why +confirmation is required by default in certain cases or if a +prompt is confusing." + ;; One would expect this to be a command as simple as, for example, + ;; `magit-branch-rename'; but it turns out everyone wants to squeeze + ;; a bit of extra functionality into this one, including myself. + (interactive + (let ((branches (magit-region-values 'branch t)) + (force current-prefix-arg)) + (if (length> branches 1) + (magit-confirm t nil "Delete %d branches" nil branches) + (setq branches + (list (magit-read-branch-prefer-other + (if force "Force delete branch" "Delete branch"))))) + (when-let (((not force)) + (unmerged (seq-remove #'magit-branch-merged-p branches))) + (if (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" + "Delete %d unmerged branches" + 'noabort unmerged) + (setq force branches) + (or (setq branches + (cl-set-difference branches unmerged :test #'equal)) + (user-error "Abort")))) + (list branches force))) + (let ((refs (mapcar #'magit-ref-fullname branches))) + ;; If a member of refs is nil, that means that + ;; the respective branch name is ambiguous. + (when-let ((ambiguous (seq-filter #'null refs))) + (user-error + "%s ambiguous; please cleanup using git directly" + (let ((len (length ambiguous))) + (cond + ((= len 1) + (format "%s is" (seq-find #'magit-ref-ambiguous-p branches))) + ((= len (length refs)) + (format "These %s names are" len)) + (t + (format "%s of these names are" len)))))) + (cond + ((string-match "^refs/remotes/\\([^/]+\\)" (car refs)) + (let* ((remote (match-string 1 (car refs))) + (offset (1+ (length remote)))) + (cond + ((magit-confirm 'delete-branch-on-remote + (list "Deleting local %s. Also delete on %s" + (magit-ref-fullname (car branches)) + remote) + (list "Deleting %d local refs. Also delete on %s" + (length refs) + remote) + 'noabort refs) + ;; The ref may actually point at another rev on the remote, + ;; but this is better than nothing. + (dolist (ref refs) + (message "Delete %s (was %s)" ref + (magit-rev-parse "--short" ref))) + ;; Assume the branches actually still exist on the remote. + (magit-run-git-async + "push" + (and (or force magit-branch-delete-never-verify) "--no-verify") + remote + (mapcar (##concat ":" (substring % offset)) branches)) + ;; If that is not the case, then this deletes the tracking branches. + (set-process-sentinel + magit-this-process + (apply-partially #'magit-delete-remote-branch-sentinel remote refs))) + (t + (dolist (ref refs) + (message "Delete %s (was %s)" ref + (magit-rev-parse "--short" ref)) + (magit-call-git "update-ref" "-d" ref)) + (magit-refresh))))) + ((length> branches 1) + (setq branches (delete (magit-get-current-branch) branches)) + (mapc #'magit-branch-maybe-delete-pr-remote branches) + (mapc #'magit-branch-unset-pushRemote branches) + (magit-run-git "branch" (if force "-D" "-d") branches)) + (t ; And now for something completely different. + (let* ((branch (car branches)) + (prompt (format "Branch %s is checked out. " branch)) + (target (magit-get-indirect-upstream-branch branch t))) + (when (equal branch (magit-get-current-branch)) + (when (or (equal branch target) + (not target)) + (setq target (magit-main-branch))) + (pcase (if (or (equal branch target) + (not target)) + (magit-read-char-case prompt nil + (?d "[d]etach HEAD & delete" 'detach) + (?a "[a]bort" 'abort)) + (magit-read-char-case prompt nil + (?d "[d]etach HEAD & delete" 'detach) + (?c (format "[c]heckout %s & delete" target) 'target) + (?a "[a]bort" 'abort))) + (`detach (unless (or (equal force '(4)) + (member branch force) + (magit-branch-merged-p branch t)) + (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" "" + nil (list branch))) + (magit-call-git "checkout" "--detach")) + (`target (unless (or (equal force '(4)) + (member branch force) + (magit-branch-merged-p branch target)) + (magit-confirm 'delete-unmerged-branch + "Delete unmerged branch %s" "" + nil (list branch))) + (magit-call-git "checkout" target)) + (`abort (user-error "Abort"))) + (setq force t)) + (magit-branch-maybe-delete-pr-remote branch) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" (if force "-D" "-d") branch)))))) + +(put 'magit-branch-delete 'interactive-only t) + +(defun magit-branch-maybe-delete-pr-remote (branch) + (when-let ((remote (magit-get "branch" branch "pullRequestRemote"))) + (let* ((variable (format "remote.%s.fetch" remote)) + (refspecs (magit-get-all variable))) + (unless (member (format "+refs/heads/*:refs/remotes/%s/*" remote) + refspecs) + (let ((refspec + (if (equal (magit-get "branch" branch "pushRemote") remote) + (format "+refs/heads/%s:refs/remotes/%s/%s" + branch remote branch) + (let ((merge (magit-get "branch" branch "merge"))) + (and merge + (string-prefix-p "refs/heads/" merge) + (setq merge (substring merge 11)) + (format "+refs/heads/%s:refs/remotes/%s/%s" + merge remote merge)))))) + (when (member refspec refspecs) + (if (and (length= refspecs 1) + (magit-confirm 'delete-pr-remote + (list "Also delete remote %s (%s)" remote + "no pull-request branch remains") + nil t)) + (magit-call-git "remote" "rm" remote) + (magit-call-git "config" "--unset-all" variable + (format "^%s$" (regexp-quote refspec)))))))))) + +(defun magit-branch-unset-pushRemote (branch) + (magit-set nil "branch" branch "pushRemote")) + +(defun magit-delete-remote-branch-sentinel (remote refs process event) + (when (memq (process-status process) '(exit signal)) + (if (= (process-exit-status process) 1) + (if-let ((on-remote (mapcar (##concat "refs/remotes/" remote "/" %) + (magit-remote-list-branches remote))) + (rest (seq-filter (##and (not (member % on-remote)) + (magit-ref-exists-p %)) + refs))) + (progn + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (setq magit-this-error nil) + (message "Some remote branches no longer exist. %s" + "Deleting just the local tracking refs instead...") + (dolist (ref rest) + (magit-call-git "update-ref" "-d" ref)) + (magit-refresh) + (message "Deleting local remote-tracking refs...done")) + (magit-process-sentinel process event)) + (magit-process-sentinel process event)))) + +;;;###autoload +(defun magit-branch-rename (old new &optional force) + "Rename the branch named OLD to NEW. + +With a prefix argument FORCE, rename even if a branch named NEW +already exists. + +If `branch.OLD.pushRemote' is set, then unset it. Depending on +the value of `magit-branch-rename-push-target' (which see) maybe +set `branch.NEW.pushRemote' and maybe rename the push-target on +the remote." + (interactive + (let ((branch (magit-read-local-branch "Rename branch"))) + (list branch + (magit-read-string-ns (format "Rename branch '%s' to" branch) + nil 'magit-revision-history) + current-prefix-arg))) + (when (string-match "\\`heads/\\(.+\\)" old) + (setq old (match-string 1 old))) + (when (equal old new) + (user-error "Old and new branch names are the same")) + (magit-call-git "branch" (if force "-M" "-m") old new) + (when magit-branch-rename-push-target + (let ((remote (magit-get-push-remote old)) + (old-specified (magit-get "branch" old "pushRemote")) + (new-specified (magit-get "branch" new "pushRemote"))) + (when (and old-specified (or force (not new-specified))) + ;; Keep the target setting branch specified, even if that is + ;; redundant. But if a branch by the same name existed before + ;; and the rename isn't forced, then do not change a leftover + ;; setting. Such a leftover setting may or may not conform to + ;; what we expect here... + (magit-set old-specified "branch" new "pushRemote")) + (when (and (equal (magit-get-push-remote new) remote) + ;; ...and if it does not, then we must abort. + (not (eq magit-branch-rename-push-target 'local-only)) + (or (not (eq magit-branch-rename-push-target 'forge-only)) + (and (require (quote forge) nil t) + (fboundp 'forge--split-forge-url) + (and-let* ((url (magit-git-string + "remote" "get-url" remote))) + (forge--split-forge-url url))))) + (let ((old-target (magit-get-push-branch old t)) + (new-target (magit-get-push-branch new t)) + (remote (magit-get-push-remote new))) + (when (and old-target + (not new-target) + (magit-y-or-n-p (format "Also rename %S to %S on \"%s\"?" + old new remote))) + ;; Rename on (i.e., within) the remote, but only if the + ;; destination ref doesn't exist yet. If that ref already + ;; exists, then it probably is of some value and we better + ;; not touch it. Ignore what the local ref points at, + ;; i.e., if the local and the remote ref didn't point at + ;; the same commit before the rename then keep it that way. + (magit-call-git "push" "-v" remote + (format "%s:refs/heads/%s" old-target new) + (format ":refs/heads/%s" old))))))) + (magit-branch-unset-pushRemote old) + (magit-refresh)) + +;;;###autoload +(defun magit-branch-shelve (branch) + "Shelve a BRANCH. +Rename \"refs/heads/BRANCH\" to \"refs/shelved/YYYY-MM-DD-BRANCH\", +and also rename the respective reflog file." + (interactive (list (magit-read-other-local-branch "Shelve branch"))) + (let ((old (concat "refs/heads/" branch)) + (new (format "refs/shelved/%s-%s" + (magit-rev-format "%cs" branch) + branch))) + (magit-git "update-ref" new old "") + (magit--rename-reflog-file old new) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" "-D" branch))) + +;;;###autoload +(defun magit-branch-unshelve (branch) + "Unshelve a BRANCH. +Rename \"refs/shelved/BRANCH\" to \"refs/heads/BRANCH\". If BRANCH +is prefixed with \"YYYY-MM-DD\", then drop that part of the name. +Also rename the respective reflog file." + (interactive + (list (magit-completing-read + "Unshelve branch" + (mapcar (##substring % 8) + (nreverse (magit-list-refnames "refs/shelved"))) + nil t))) + (let ((old (concat "refs/shelved/" branch)) + (new (concat "refs/heads/" + (if (string-match-p + "\\`[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-" branch) + (substring branch 11) + branch)))) + (magit-git "update-ref" new old "") + (magit--rename-reflog-file old new) + (magit-run-git "update-ref" "-d" old))) + +(defun magit--rename-reflog-file (old new) + (let* ((dir (magit-gitdir)) + (old (expand-file-name (concat "logs/" old) dir)) + (new (expand-file-name (concat "logs/" new) dir))) + (when (file-exists-p old) + (make-directory (file-name-directory new) t) + (rename-file old new t)))) + +;;; Configure + +;;;###autoload (autoload 'magit-branch-configure "magit-branch" nil t) +(transient-define-prefix magit-branch-configure (branch) + "Configure a branch." + :man-page "git-branch" + [:description (##concat + (propertize "Configure " 'face 'transient-heading) + (propertize (transient-scope) 'face 'magit-branch-local)) + ("d" magit-branch..description) + ("u" magit-branch..merge/remote) + ("r" magit-branch..rebase) + ("p" magit-branch..pushRemote)] + ["Configure repository defaults" + ("R" magit-pull.rebase) + ("P" magit-remote.pushDefault) + ("B" "Update default branch" magit-update-default-branch + :inapt-if-not magit-get-some-remote)] + ["Configure branch creation" + ("a m" magit-branch.autoSetupMerge) + ("a r" magit-branch.autoSetupRebase)] + (interactive + (list (or (and (not current-prefix-arg) + (not (and magit-branch-direct-configure + (eq transient-current-command 'magit-branch))) + (magit-get-current-branch)) + (magit--read-branch-scope)))) + (transient-setup 'magit-branch-configure nil nil :scope branch)) + +(defun magit--read-branch-scope (&optional obj) + (magit-read-local-branch + (if obj + (format "Set %s for branch" + (format (oref obj variable) "")) + "Configure branch"))) + +(transient-define-suffix magit-branch..description (branch) + "Edit the description of BRANCH." + :class 'magit--git-variable + :transient nil + :variable "branch.%s.description" + (interactive (list (oref transient-current-prefix scope))) + (magit-run-git-with-editor "branch" "--edit-description" branch)) + +(defclass magit--git-branch:upstream (magit--git-variable) + ((format :initform " %k %m %M\n %r %R"))) + +(transient-define-infix magit-branch..merge/remote () + :class 'magit--git-branch:upstream) + +(cl-defmethod transient-init-value ((obj magit--git-branch:upstream)) + (when-let* ((branch (transient-scope)) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (oset obj value (list remote merge)))) + +(cl-defmethod transient-infix-read ((obj magit--git-branch:upstream)) + (if (oref obj value) + (oset obj value nil) + (magit-read-upstream-branch (transient-scope) "Upstream"))) + +(cl-defmethod transient-infix-set ((obj magit--git-branch:upstream) refname) + (magit-set-upstream-branch (transient-scope) refname) + (oset obj value + (and-let* ((branch (transient-scope)) + (r (magit-get "branch" branch "remote")) + (m (magit-get "branch" branch "merge"))) + (list r m))) + (magit-refresh)) + +(cl-defmethod transient-format ((obj magit--git-branch:upstream)) + (let ((branch (transient-scope))) + (format-spec + (oref obj format) + `((?k . ,(transient-format-key obj)) + (?r . ,(format "branch.%s.remote" branch)) + (?m . ,(format "branch.%s.merge" branch)) + (?R . ,(transient-format-value obj #'car)) + (?M . ,(transient-format-value obj #'cadr)))))) + +(cl-defmethod transient-format-value ((obj magit--git-branch:upstream) key) + (if-let ((value (funcall key (oref obj value)))) + (propertize value 'face 'transient-argument) + (propertize "unset" 'face 'transient-inactive-argument))) + +(transient-define-infix magit-branch..rebase () + :class 'magit--git-variable:choices + :scope #'magit--read-branch-scope + :variable "branch.%s.rebase" + :fallback "pull.rebase" + :choices '("true" "false") + :default "false") + +(transient-define-infix magit-branch..pushRemote () + :class 'magit--git-variable:choices + :scope #'magit--read-branch-scope + :variable "branch.%s.pushRemote" + :fallback "remote.pushDefault" + :choices #'magit-list-remotes) + +(transient-define-infix magit-pull.rebase () + :class 'magit--git-variable:choices + :variable "pull.rebase" + :choices '("true" "false") + :default "false") + +(transient-define-infix magit-remote.pushDefault () + :class 'magit--git-variable:choices + :variable "remote.pushDefault" + :choices #'magit-list-remotes) + +(transient-define-infix magit-branch.autoSetupMerge () + :class 'magit--git-variable:choices + :variable "branch.autoSetupMerge" + :choices '("always" "true" "false") + :default "true") + +(transient-define-infix magit-branch.autoSetupRebase () + :class 'magit--git-variable:choices + :variable "branch.autoSetupRebase" + :choices '("always" "local" "remote" "never") + :default "never") + +;;; _ +(provide 'magit-branch) +;;; magit-branch.el ends here blob - /dev/null blob + 1cd98d5519c868a9b80b362c3192d12b465e28ef (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-bundle.el @@ -0,0 +1,139 @@ +;;; magit-bundle.el --- Bundle support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for "git bundle". +;; The entry point is the `magit-bundle' menu command. + +;; See (man "git-bundle"). + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-bundle "magit-bundle" nil t) +(transient-define-prefix magit-bundle () + "Create or verify Git bundles." + :man-page "git-bundle" + ["Actions" + ("c" "create" magit-bundle-create) + ("v" "verify" magit-bundle-verify) + ("l" "list-heads" magit-bundle-list-heads)]) + +;;;###autoload (autoload 'magit-bundle-import "magit-bundle" nil t) +(transient-define-prefix magit-bundle-create (&optional file refs args) + "Create a bundle." + :man-page "git-bundle" + ["Arguments" + ("-a" "Include all refs" "--all") + ("-b" "Include branches" "--branches=" :allow-empty t) + ("-t" "Include tags" "--tags=" :allow-empty t) + ("-r" "Include remotes" "--remotes=" :allow-empty t) + ("-g" "Include refs" "--glob=") + ("-e" "Exclude refs" "--exclude=") + (magit-log:-n) + (magit-log:--since) + (magit-log:--until)] + ["Actions" + ("c" "create regular bundle" magit-bundle-create) + ("t" "create tracked bundle" magit-bundle-create-tracked) + ("u" "update tracked bundle" magit-bundle-update-tracked)] + (interactive + (and (eq transient-current-command 'magit-bundle-create) + (list (read-file-name "Create bundle: " nil nil nil + (concat (file-name-nondirectory + (directory-file-name (magit-toplevel))) + ".bundle")) + (magit-completing-read-multiple "Refnames (zero or more): " + (magit-list-refnames)) + (transient-args 'magit-bundle-create)))) + (if file + (magit-git-bundle "create" file refs args) + (transient-setup 'magit-bundle-create))) + +;;;###autoload +(defun magit-bundle-create-tracked (file tag branch refs args) + "Create and track a new bundle." + (interactive + (let ((tag (magit-read-tag "Track bundle using tag")) + (branch (magit-read-branch "Bundle branch")) + (refs (magit-completing-read-multiple + "Additional refnames (zero or more): " + (magit-list-refnames)))) + (list (read-file-name "File: " nil nil nil (concat tag ".bundle")) + tag branch + (if (equal branch (magit-get-current-branch)) + (cons "HEAD" refs) + refs) + (transient-args 'magit-bundle-create)))) + (magit-git-bundle "create" file (cons branch refs) args) + (magit-git "tag" "--force" tag branch + "-m" (concat ";; git-bundle tracking\n" + (pp-to-string `((file . ,file) + (branch . ,branch) + (refs . ,refs) + (args . ,args)))))) + +;;;###autoload +(defun magit-bundle-update-tracked (tag) + "Update a bundle that is being tracked using TAG." + (interactive (list (magit-read-tag "Update bundle tracked by tag" t))) + (let (msg) + (let-alist (magit--with-temp-process-buffer + (save-excursion + (magit-git-insert "for-each-ref" "--format=%(contents)" + (concat "refs/tags/" tag))) + (setq msg (buffer-string)) + (ignore-errors (read (current-buffer)))) + (unless (and .file .branch) + (error "Tag %s does not appear to track a bundle" tag)) + (magit-git-bundle "create" .file + (cons (concat tag ".." .branch) .refs) + .args) + (magit-git "tag" "--force" tag .branch "-m" msg)))) + +;;;###autoload +(defun magit-bundle-verify (file) + "Check whether FILE is valid and applies to the current repository." + (interactive (list (magit-bundle--read-file-name "Verify bundle: "))) + (magit-process-buffer) + (magit-git-bundle "verify" file)) + +;;;###autoload +(defun magit-bundle-list-heads (file) + "List the refs in FILE." + (interactive (list (magit-bundle--read-file-name "List heads of bundle: "))) + (magit-process-buffer) + (magit-git-bundle "list-heads" file)) + +(defun magit-bundle--read-file-name (prompt) + (read-file-name prompt nil nil t (magit-file-at-point) #'file-regular-p)) + +(defun magit-git-bundle (command file &optional refs args) + (magit-git "bundle" command (magit-convert-filename-for-git file) refs args)) + +;;; _ +(provide 'magit-bundle) +;;; magit-bundle.el ends here blob - /dev/null blob + 42187eb3c672a94bf15dd24944819d971bc51f72 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-clone.el @@ -0,0 +1,351 @@ +;;; magit-clone.el --- Clone a repository -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements clone commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-clone-set-remote-head nil + "Whether cloning creates the symbolic-ref `/HEAD'." + :package-version '(magit . "2.4.2") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-clone-set-remote.pushDefault 'ask + "Whether to set the value of `remote.pushDefault' after cloning. + +If t, then set without asking. If nil, then don't set. If +`ask', then ask." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(choice (const :tag "Set" t) + (const :tag "Ask" ask) + (const :tag "Don't set" nil))) + +(defcustom magit-clone-default-directory nil + "Default directory to use when `magit-clone' reads destination. +If nil (the default), then use the value of `default-directory'. +If a directory, then use that. If a function, then call that +with the remote url as only argument and use the returned value." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type '(choice (const :tag "Value of default-directory") + (directory :tag "Constant directory") + (function :tag "Function's value"))) + +(defcustom magit-clone-always-transient nil + "Whether `magit-clone' always acts as a transient prefix command. +If nil, then a prefix argument has to be used to show the transient +popup instead of invoking the default suffix `magit-clone-regular' +directly." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-clone-name-alist + '(("\\`\\(?:github:\\|gh:\\)?\\([^:]+\\)\\'" "github.com" "github.user") + ("\\`\\(?:gitlab:\\|gl:\\)\\([^:]+\\)\\'" "gitlab.com" "gitlab.user") + ("\\`\\(?:sourcehut:\\|sh:\\)\\([^:]+\\)\\'" "git.sr.ht" "sourcehut.user")) + "Alist mapping repository names to repository urls. + +Each element has the form (REGEXP HOSTNAME USER). When the user +enters a name when a cloning command asks for a name or url, then +that is looked up in this list. The first element whose REGEXP +matches is used. + +The format specified by option `magit-clone-url-format' is used +to turn the name into an url, using HOSTNAME and the repository +name. If the provided name contains a slash, then that is used. +Otherwise if the name omits the owner of the repository, then the +default user specified in the matched entry is used. + +If USER contains a dot, then it is treated as a Git variable and +the value of that is used as the username. Otherwise it is used +as the username itself." + :package-version '(magit . "4.0.0") + :group 'magit-commands + :type '(repeat (list regexp + (string :tag "Hostname") + (string :tag "User name or git variable")))) + +(defcustom magit-clone-url-format + '(("git.sr.ht" . "git@%h:%n") + (t . "git@%h:%n.git")) + "Format(s) used when turning repository names into urls. + +In a format string, %h is the hostname and %n is the repository +name, including the name of the owner. + +The value can be a string (representing a single static format) +or an alist with elements (HOSTNAME . FORMAT) mapping hostnames +to formats. When an alist is used, the t key represents the +default. Also see `magit-clone-name-alist'." + :package-version '(magit . "4.0.0") + :group 'magit-commands + :type '(choice (string :tag "Format") + (alist :key-type (choice (string :tag "Host") + (const :tag "Default" t)) + :value-type (string :tag "Format")))) + +(defcustom magit-post-clone-hook nil + "Hook run after the repository has been successfully cloned. + +When the hook is called, `default-directory' is let-bound to the +directory where the repository has been cloned." + :package-version '(magit . "4.0.0") + :group 'magit-commands + :type 'hook) + +;;; Commands + +;;;###autoload (autoload 'magit-clone "magit-clone" nil t) +(transient-define-prefix magit-clone (&optional transient) + "Clone a repository." + :man-page "git-clone" + ["Fetch arguments" + ("-B" "Clone a single branch" "--single-branch") + ("-n" "Do not clone tags" "--no-tags") + ("-S" "Clones submodules" "--recurse-submodules" :level 6) + ("-l" "Do not optimize" "--no-local" :level 7)] + ["Setup arguments" + ("-o" "Set name of remote" ("-o" "--origin=")) + ("-b" "Set HEAD branch" ("-b" "--branch=")) + (magit-clone:--filter :level 7) + ("-g" "Separate git directory" "--separate-git-dir=" + transient-read-directory :level 7) + ("-t" "Use template directory" "--template=" + transient-read-existing-directory :level 6)] + ["Local sharing arguments" + ("-s" "Share objects" ("-s" "--shared" :level 7)) + ("-h" "Do not use hardlinks" "--no-hardlinks")] + ["Clone" + ("C" "regular" magit-clone-regular) + ("s" "shallow" magit-clone-shallow) + ("d" "shallow since date" magit-clone-shallow-since :level 7) + ("e" "shallow excluding" magit-clone-shallow-exclude :level 7) + (">" "sparse checkout" magit-clone-sparse :level 6) + ("b" "bare" magit-clone-bare) + ("m" "mirror" magit-clone-mirror)] + (interactive (list (or magit-clone-always-transient current-prefix-arg))) + (if transient + (transient-setup 'magit-clone) + (call-interactively #'magit-clone-regular))) + +(transient-define-argument magit-clone:--filter () + :description "Filter some objects" + :class 'transient-option + :key "-f" + :argument "--filter=" + :reader #'magit-clone-read-filter) + +(defun magit-clone-read-filter (prompt initial-input history) + (magit-completing-read prompt + (list "blob:none" "tree:0") + nil nil initial-input history)) + +;;;###autoload +(defun magit-clone-regular (repository directory args) + "Create a clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory args)) + +;;;###autoload +(defun magit-clone-shallow (repository directory args depth) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +With a prefix argument read the DEPTH of the clone; +otherwise use 1." + (interactive (append (magit-clone-read-args) + (list (if current-prefix-arg + (read-number "Depth: " 1) + 1)))) + (magit-clone-internal repository directory + (cons (format "--depth=%s" depth) args))) + +;;;###autoload +(defun magit-clone-shallow-since (repository directory args date) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits before DATE, which is read from the +user." + (interactive (append (magit-clone-read-args) + (list (transient-read-date "Exclude commits before: " + nil nil)))) + (magit-clone-internal repository directory + (cons (format "--shallow-since=%s" date) args))) + +;;;###autoload +(defun magit-clone-shallow-exclude (repository directory args exclude) + "Create a shallow clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository. +Exclude commits reachable from EXCLUDE, which is a +branch or tag read from the user." + (interactive (append (magit-clone-read-args) + (list (read-string "Exclude commits reachable from: ")))) + (magit-clone-internal repository directory + (cons (format "--shallow-exclude=%s" exclude) args))) + +;;;###autoload +(defun magit-clone-bare (repository directory args) + "Create a bare clone of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory (cons "--bare" args))) + +;;;###autoload +(defun magit-clone-mirror (repository directory args) + "Create a mirror of REPOSITORY in DIRECTORY. +Then show the status buffer for the new repository." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory (cons "--mirror" args))) + +;;;###autoload +(defun magit-clone-sparse (repository directory args) + "Clone REPOSITORY into DIRECTORY and create a sparse checkout." + (interactive (magit-clone-read-args)) + (magit-clone-internal repository directory (cons "--no-checkout" args) + 'sparse)) + +(defun magit-clone-internal (repository directory args &optional sparse) + (let* ((checkout (not (member (car args) '("--bare" "--mirror")))) + (remote (or (transient-arg-value "--origin=" args) + (magit-get "clone.defaultRemote") + "origin")) + (set-push-default + (and checkout + (or (eq magit-clone-set-remote.pushDefault t) + (and magit-clone-set-remote.pushDefault + (y-or-n-p (format "Set `remote.pushDefault' to %S? " + remote))))))) + (run-hooks 'magit-credential-hook) + (setq directory (file-name-as-directory (expand-file-name directory))) + (when (file-exists-p directory) + (if (file-directory-p directory) + (when (length> (directory-files directory) 2) + (let ((name (magit-clone--url-to-name repository))) + (unless (and name + (setq directory (file-name-as-directory + (expand-file-name name directory))) + (not (file-exists-p directory))) + (user-error "%s already exists" directory)))) + (user-error "%s already exists and is not a directory" directory))) + (magit-run-git-async "clone" args "--" repository + (magit-convert-filename-for-git directory)) + ;; Don't refresh the buffer we're calling from. + (process-put magit-this-process 'inhibit-refresh t) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (let ((magit-process-raise-error t)) + (magit-process-sentinel process event))) + (when (and (eq (process-status process) 'exit) + (= (process-exit-status process) 0)) + (when checkout + (let ((default-directory directory)) + (when set-push-default + (setf (magit-get "remote.pushDefault") remote)) + (unless magit-clone-set-remote-head + (magit-remote-unset-head remote)))) + (when (and sparse checkout) + (let ((default-directory directory)) + (magit-call-git "sparse-checkout" "init" "--cone") + (magit-call-git "checkout" (magit-get-current-branch)))) + (let ((default-directory directory)) + (run-hooks 'magit-post-clone-hook)) + (with-current-buffer (process-get process 'command-buf) + (magit-status-setup-buffer directory))))))) + +(defun magit-clone-read-args () + (let ((repo (magit-clone-read-repository))) + (list repo + (read-directory-name + "Clone to: " + (if (functionp magit-clone-default-directory) + (funcall magit-clone-default-directory repo) + magit-clone-default-directory) + nil nil + (magit-clone--url-to-name repo)) + (transient-args 'magit-clone)))) + +(defun magit-clone-read-repository () + (magit-read-char-case "Clone from " nil + (?u "[u]rl or name" + (let ((str (magit-read-string-ns "Clone from url or name"))) + (if (string-match-p "\\(://\\|@\\)" str) + str + (magit-clone--name-to-url str)))) + (?p "[p]ath" + (magit-convert-filename-for-git + (read-directory-name "Clone repository: "))) + (?l "[l]ocal url" + (concat "file://" + (magit-convert-filename-for-git + (read-directory-name "Clone repository: file://")))) + (?b "[b]undle" + (magit-convert-filename-for-git + (read-file-name "Clone from bundle: "))))) + +(defun magit-clone--url-to-name (url) + (and (string-match "\\([^/:]+?\\)\\(/?\\.git\\)?$" url) + (match-string 1 url))) + +(defun magit-clone--name-to-url (name) + (or (seq-some + (pcase-lambda (`(,re ,host ,user)) + (and (string-match re name) + (let ((repo (match-string 1 name))) + (magit-clone--format-url host user repo)))) + magit-clone-name-alist) + (user-error "Not an url and no matching entry in `%s'" + 'magit-clone-name-alist))) + +(defun magit-clone--format-url (host user repo) + (if-let ((url-format + (cond ((listp magit-clone-url-format) + (cdr (or (assoc host magit-clone-url-format) + (assoc t magit-clone-url-format)))) + ((stringp magit-clone-url-format) + magit-clone-url-format)))) + (format-spec + url-format + `((?h . ,host) + (?n . ,(if (string-search "/" repo) + repo + (if (string-search "." user) + (if-let ((user (magit-get user))) + (concat user "/" repo) + (user-error "Set %S or specify owner explicitly" user)) + (concat user "/" repo)))))) + (user-error + "Bogus `magit-clone-url-format' (bad type or missing default)"))) + +;;; _ +(provide 'magit-clone) +;;; magit-clone.el ends here blob - /dev/null blob + e8b84383f2f502b0b08eb59d90aec0ac53624daf (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-commit.el @@ -0,0 +1,816 @@ +;;; magit-commit.el --- Create Git commits -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements commands for creating Git commits. These +;; commands just initiate the commit, support for writing the commit +;; messages is implemented in `git-commit.el'. + +;;; Code: + +(require 'magit) +(require 'magit-sequence) + +;;; Options + +(defcustom magit-commit-ask-to-stage 'verbose + "Whether to ask to stage everything when committing and nothing is staged." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type '(choice (const :tag "Ask" t) + (const :tag "Ask showing diff" verbose) + (const :tag "Stage without confirmation" stage) + (const :tag "Don't ask" nil))) + +(defcustom magit-commit-show-diff t + "Whether the relevant diff is automatically shown when committing." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-extend-override-date t + "Whether using `magit-commit-extend' changes the committer date." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-reword-override-date t + "Whether using `magit-commit-reword' changes the committer date." + :package-version '(magit . "2.3.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-commit-squash-confirm t + "Whether the commit targeted by squash and fixup has to be confirmed. +When non-nil then the commit at point (if any) is used as default +choice, otherwise it has to be confirmed. This option only +affects `magit-commit-squash' and `magit-commit-fixup'. The +\"instant\" variants always require confirmation because making +an error while using those is harder to recover from." + :package-version '(magit . "2.1.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-post-commit-hook nil + "Hook run after creating a commit without the user editing a message. + +This hook is run by `magit-refresh' if `this-command' is a member +of `magit-post-commit-hook-commands'. This only includes commands +named `magit-commit-*' that do *not* require that the user edits +the commit message in a buffer and then finishes by pressing +\\\\[with-editor-finish]. + +Also see `git-commit-post-finish-hook'." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'hook) + +(defcustom magit-commit-diff-inhibit-same-window nil + "Whether to inhibit use of same window when showing diff while committing. + +When writing a commit, then a diff of the changes to be committed +is automatically shown. The idea is that the diff is shown in a +different window of the same frame and for most users that just +works. In other words most users can completely ignore this +option because its value doesn't make a difference for them. + +However for users who configured Emacs to never create a new +window even when the package explicitly tries to do so, then +displaying two new buffers necessarily means that the first is +immediately replaced by the second. In our case the message +buffer is immediately replaced by the diff buffer, which is of +course highly undesirable. + +A workaround is to suppress this user configuration in this +particular case. Users have to explicitly opt-in by toggling +this option. We cannot enable the workaround unconditionally +because that again causes issues for other users: if the frame +is too tiny or the relevant settings too aggressive, then the +diff buffer would end up being displayed in a new frame. + +Also see https://github.com/magit/magit/issues/4132." + :package-version '(magit . "3.3.0") + :group 'magit-commands + :type 'boolean) + +;;; Popup + +;;;###autoload (autoload 'magit-commit "magit-commit" nil t) +(transient-define-prefix magit-commit () + "Create a new commit or replace an existing commit." + :info-manual "(magit)Initiating a Commit" + :man-page "git-commit" + ["Arguments" + ("-a" "Stage all modified and deleted files" ("-a" "--all")) + ("-e" "Allow empty commit" "--allow-empty") + ("-v" "Show diff of changes to be committed" ("-v" "--verbose")) + ("-n" "Disable hooks" ("-n" "--no-verify")) + ("-R" "Claim authorship and reset author date" "--reset-author") + (magit:--author :description "Override the author") + (magit-commit:--date :level 7) + (magit:--gpg-sign :level 5) + (magit:--signoff) + (magit-commit:--reuse-message)] + [["Create" + ("c" "Commit" magit-commit-create)] + ["Edit HEAD" + ("e" "Extend" magit-commit-extend) + "" + ("a" "Amend" magit-commit-amend) + "" + ("w" "Reword" magit-commit-reword) + ("d" "Reshelve" magit-commit-reshelve :level 0)] + ["Edit" + ("f" "Fixup" magit-commit-fixup) + ("s" "Squash" magit-commit-squash) + ("A" "Alter" magit-commit-alter) + ("n" "Augment" magit-commit-augment) + ("W" "Revise" magit-commit-revise)] + ["Edit and rebase" + ("F" "Instant fixup" magit-commit-instant-fixup) + ("S" "Instant squash" magit-commit-instant-squash) + "" + "" + ("R" "Reword past" magit-rebase-reword-commit :level 0)] + ["Spread across commits" + ("x" "Modified files" magit-commit-autofixup :level 6) + ("X" "Updated modules" magit-commit-absorb-modules :level 6)]] + (interactive) + (if-let ((buffer (magit-commit-message-buffer))) + (switch-to-buffer buffer) + (transient-setup 'magit-commit))) + +(defun magit-commit-arguments nil + (transient-args 'magit-commit)) + +(transient-define-argument magit-commit:--date () + :description "Override the author date" + :class 'transient-option + :shortarg "-D" + :argument "--date=" + :reader #'transient-read-date) + +(transient-define-argument magit-commit:--reuse-message () + :description "Reuse commit message" + :class 'transient-option + :shortarg "-C" + :argument "--reuse-message=" + :reader #'magit-read-reuse-message + :history-key 'magit-revision-history) + +(defun magit-read-reuse-message (prompt &optional default history) + (magit-completing-read prompt (magit-list-refnames) + nil nil nil history + (or default + (and (magit-rev-verify "ORIG_HEAD") + "ORIG_HEAD")))) + +;;; Commands +;;;; Create + +;;;###autoload +(defun magit-commit-create (&optional args) + "Create a new commit." + (interactive (list (magit-commit-arguments))) + (cond ((member "--all" args) + (setq this-command 'magit-commit--all)) + ((member "--allow-empty" args) + (setq this-command 'magit-commit--allow-empty))) + (when (setq args (magit-commit-assert args)) + (let ((default-directory (magit-toplevel))) + (magit-run-git-with-editor "commit" args)))) + +;;;; Edit HEAD + +;;;###autoload +(defun magit-commit-extend (&optional args override-date) + "Amend staged changes to the last commit, without editing its message. + +With a prefix argument do not update the committer date; without an +argument update it. The option `magit-commit-extend-override-date' +can be used to inverse the meaning of the prefix argument. Called +non-interactively, the optional OVERRIDE-DATE argument controls this +behavior, and the option is of no relevance." + (interactive (list (magit-commit-arguments) + (if current-prefix-arg + (not magit-commit-extend-override-date) + magit-commit-extend-override-date))) + (when (setq args (magit-commit-assert args)) + (magit-commit-amend-assert) + (if override-date + (magit-run-git-with-editor "commit" "--amend" "--no-edit" args) + (with-environment-variables + (("GIT_COMMITTER_DATE" (magit-rev-format "%cD"))) + (magit-run-git-with-editor "commit" "--amend" "--no-edit" args))))) + +;;;###autoload +(defun magit-commit-amend (&optional args) + "Amend staged changes (if any) to the last commit, and edit its message." + (interactive (list (magit-commit-arguments))) + (magit-commit-amend-assert) + (magit-run-git-with-editor "commit" "--amend" args)) + +;;;###autoload +(defun magit-commit-reword (&optional args override-date) + "Reword the message of the last commit, without amending its tree. + +With a prefix argument do not update the committer date; without an +argument update it. The option `magit-commit-reword-override-date' +can be used to inverse the meaning of the prefix argument. Called +non-interactively, the optional OVERRIDE-DATE argument controls this +behavior, and the option is of no relevance." + (interactive (list (magit-commit-arguments) + (if current-prefix-arg + (not magit-commit-reword-override-date) + magit-commit-reword-override-date))) + (magit-commit-amend-assert) + (cl-pushnew "--allow-empty" args :test #'equal) + (if override-date + (magit-run-git-with-editor "commit" "--amend" "--only" args) + (with-environment-variables + (("GIT_COMMITTER_DATE" (magit-rev-format "%cD"))) + (magit-run-git-with-editor "commit" "--amend" "--only" args)))) + +;;;; Edit + +;;;###autoload +(defun magit-commit-fixup (&optional commit args) + "Create a fixup commit, leaving the original commit message untouched. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the original message of the targeted commit is used as-is. + +In other words, call \"git commit --fixup=COMMIT --no-edit\"." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup=" commit args)) + +;;;###autoload +(defun magit-commit-squash (&optional commit args) + "Create a squash commit, without the user authoring a commit message. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the user is given a chance to edit the original message to take +the changes from the squash commit into account. + +In other words, call \"git commit --squash=COMMIT --no-edit\"." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash=" commit args)) + +;;;###autoload +(defun magit-commit-alter (&optional commit args) + "Create a squash commit, authoring the final commit message now. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the original message of the targeted commit is replaced with the +message of this commit, without the user automatically being given a +chance to edit again. + +In other words, call \"git commit --fixup=amend:COMMIT --edit\"." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup=amend:" commit args nil 'edit)) + +;;;###autoload +(defun magit-commit-augment (&optional commit args) + "Create a squash commit, authoring a new temporary commit message. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, the user is asked to write a final commit message, in a buffer +that starts out containing both the original commit message, as well as +the temporary commit message of the squash commit. + +In other words, call \"git commit --squash=COMMIT --edit\"." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash=" commit args nil 'edit)) + +;;;###autoload +(defun magit-commit-revise (&optional commit args) + "Reword the message of an existing commit, without editing its tree. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +During a later rebase, when this commit gets squashed into its targeted +commit, a combined commit is created which uses the message of the fixup +commit and the tree of the targeted commit. + +In other words, call \"git commit --fixup=reword:COMMIT --edit\"." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup=reword:" commit args 'nopatch 'edit)) + +;;;; Edit and Rebase + +;;;###autoload +(defun magit-commit-instant-fixup (&optional commit args) + "Create a fixup commit, and immediately combine it with its target. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +Leave the original commit message of the targeted commit untouched. + +Like `magit-commit-fixup' but also run a `--autofixup' rebase." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--fixup=" commit args nil nil 'rebase)) + +;;;###autoload +(defun magit-commit-instant-squash (&optional commit args) + "Create a squash commit, and immediately combine it with its target. + +If there is a reachable commit at point, target that. Otherwise prompt +for a commit. If `magit-commit-squash-confirm' is non-nil, always make +the user explicitly select a commit, in a buffer dedicated to that task. + +Turing the rebase phase, when the two commits are being squashed, ask +the user to author the final commit message, based on the original +message of the targeted commit. + +Like `magit-commit-squash' but also run a `--autofixup' rebase." + (interactive (list (magit-commit-at-point) + (magit-commit-arguments))) + (magit-commit-squash-internal "--squash=" commit args nil nil 'rebase)) + +;;;; Internal + +(defun magit-commit-squash-internal + (option commit &optional args nopatch edit rebase confirmed) + (when-let ((args (magit-commit-assert args nopatch (not edit)))) + (when (and commit rebase (not (magit-rev-ancestor-p commit "HEAD"))) + (magit-read-char-case + (format "%s isn't an ancestor of HEAD. " commit) nil + (?c "[c]reate without rebasing" (setq rebase nil)) + (?s "[s]elect other" (setq commit nil)) + (?a "[a]bort" (user-error "Quit")))) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit + (or confirmed + (not (or rebase + current-prefix-arg + magit-commit-squash-confirm)))) + (let ((magit-commit-show-diff nil)) + (push (concat option commit) args) + (push (if edit "--edit" "--no-edit") args) + (if rebase + (magit-with-editor + (magit-call-git + "commit" "--no-gpg-sign" + (seq-remove (apply-partially #'string-prefix-p "--gpg-sign=") + args))) + (magit-run-git-with-editor "commit" args)) + t) ; The commit was created; used by below lambda. + (let ((winconf (and magit-commit-show-diff + (current-window-configuration)))) + (magit-log-select + (lambda (commit) + (when (and (magit-commit-squash-internal option commit args + nopatch edit rebase t) + rebase) + (magit-commit-amend-assert commit) + (magit-rebase-interactive-1 commit + (list "--autosquash" "--autostash" "--keep-empty") + "" "true" nil t)) + (when winconf + (set-window-configuration winconf))) + (format "Type %%p on a commit to %s into it," + (substring option 2)) + nil nil nil commit)) + (when (and magit-commit-show-diff (not nopatch)) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-diff-staged nil (magit-diff-arguments))))))) + +(defun magit-commit-amend-assert (&optional commit) + (when-let ((branches (magit-list-publishing-branches commit))) + (let ((m1 "This commit has already been published to ") + (m2 ".\nDo you really want to modify it")) + (magit-confirm 'amend-published + (concat m1 "%s" m2) + (concat m1 "%d public branches" m2) + nil branches)))) + +(defun magit-commit-assert (args &optional nopatch strict) + (cond + (nopatch (or args (list "--"))) + ((or (magit-anything-staged-p) + (and (magit-anything-unstaged-p) + ;; ^ Everything of nothing is still nothing. + (member "--all" args)) + (and (not strict) + ;; ^ For amend variants that don't make sense otherwise. + (or (member "--amend" args) + (member "--allow-empty" args) + (member "--reset-author" args) + (member "--signoff" args) + (transient-arg-value "--author=" args) + (transient-arg-value "--date=" args)))) + (or args (list "--"))) + ((and (magit-rebase-in-progress-p) + (not (magit-anything-unstaged-p)) + (y-or-n-p "Nothing staged. Continue in-progress rebase? ")) + (setq this-command #'magit-rebase-continue) + (magit-run-git-sequencer "rebase" "--continue") + nil) + ((file-exists-p (expand-file-name "MERGE_MSG" (magit-gitdir))) + (cond ((magit-anything-unmerged-p) + (user-error "Unresolved conflicts")) + ((and (magit-anything-unstaged-p) + (not (y-or-n-p + "Proceed with merge despite unstaged changes? "))) + (user-error "Abort")) + ((or args (list "--"))))) + ((not (magit-anything-unstaged-p)) + (user-error "Nothing staged (or unstaged)")) + (magit-commit-ask-to-stage + (when (eq magit-commit-ask-to-stage 'verbose) + (apply #'magit-diff-unstaged (magit-diff-arguments))) + (prog1 (when (or (eq magit-commit-ask-to-stage 'stage) + (y-or-n-p + "Nothing staged. Commit all uncommitted changes? ")) + (setq this-command 'magit-commit--all) + (cons "--all" (or args (list "--")))) + (when (and (eq magit-commit-ask-to-stage 'verbose) + (derived-mode-p 'magit-diff-mode)) + (magit-mode-bury-buffer)))) + (t + (user-error "Nothing staged")))) + +;;;; Reshelve + +(defvar magit--reshelve-history nil) + +;;;###autoload +(defun magit-commit-reshelve (date update-author &optional args) + "Change committer (and possibly author) date of the last commit. + +The current time is used as the initial minibuffer input and the +original author or committer date is available as the previous +history element. + +Both the author and the committer dates are changed, unless one +of the following is true, in which case only the committer date +is updated: +- You are not the author of the commit that is being reshelved. +- The command was invoked with a prefix argument. +- Non-interactively if UPDATE-AUTHOR is nil." + (interactive + (let ((update-author (and (magit-rev-author-p "HEAD") + (not current-prefix-arg)))) + (push (magit-rev-format (if update-author "%ad" "%cd") "HEAD" + (concat "--date=format:%F %T %z")) + magit--reshelve-history) + (list (read-string (if update-author + "Change author and committer dates to: " + "Change committer date to: ") + (cons (format-time-string "%F %T %z") 17) + 'magit--reshelve-history) + update-author + (magit-commit-arguments)))) + (with-environment-variables (("GIT_COMMITTER_DATE" date)) + (magit-run-git "commit" "--amend" "--no-edit" + (and update-author (concat "--date=" date)) + args))) + +;;;; Spread + +;;;###autoload +(defun magit-commit-absorb-modules (phase commit) + "Spread modified modules across recent commits." + (interactive (list 'select (magit-get-upstream-branch))) + (let ((modules (magit-list-modified-modules))) + (unless modules + (user-error "There are no modified modules that could be absorbed")) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit (eq phase 'run)) + (progn + (dolist (module modules) + (when-let ((msg (magit-git-string + "log" "-1" "--format=%s" + (concat commit "..") "--" module))) + (magit-git "commit" "-m" (concat "fixup! " msg) + "--only" "--" module))) + (magit-refresh) + t) + (magit-log-select + (lambda (commit) + (magit-commit-absorb-modules 'run commit)) + nil nil nil nil commit)))) + +;;;###autoload (autoload 'magit-commit-absorb "magit-commit" nil t) +(transient-define-prefix magit-commit-absorb (phase commit args) + "Spread staged changes across recent commits. +With a prefix argument use a transient command to select infix +arguments. This command requires git-absorb executable, which +is available from https://github.com/tummychow/git-absorb. +See `magit-commit-autofixup' for an alternative implementation." + :value '("-v") + ["Arguments" + ("-f" "Skip safety checks" ("-f" "--force")) + ("-v" "Increase verbosity" ("-v" "--verbose"))] + ["Actions" + ("x" "Absorb" magit-commit-absorb)] + (interactive (if current-prefix-arg + (list 'transient nil nil) + (list 'select + (magit-get-upstream-branch) + (transient-args 'magit-commit-absorb)))) + (if (eq phase 'transient) + (transient-setup 'magit-commit-absorb) + (unless (magit-git-executable-find "git-absorb") + (user-error "This command requires the git-absorb executable, which %s" + "is available from https://github.com/tummychow/git-absorb")) + (unless (magit-anything-staged-p) + (if (magit-anything-unstaged-p) + (if (y-or-n-p "Nothing staged. Absorb all unstaged changes? ") + (magit-with-toplevel + (magit-run-git "add" "-u" ".")) + (user-error "Abort")) + (user-error "There are no changes that could be absorbed"))) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit (eq phase 'run)) + (progn (magit-run-git-async "absorb" args "-b" commit) t) + (magit-log-select + (lambda (commit) + (with-no-warnings ; about non-interactive use + (magit-commit-absorb 'run commit args))) + nil nil nil nil commit)))) + +(transient-augment-suffix magit-commit-absorb :transient 'transient--do-exit) + +;;;###autoload (autoload 'magit-commit-autofixup "magit-commit" nil t) +(transient-define-prefix magit-commit-autofixup (phase commit args) + "Spread staged or unstaged changes across recent commits. + +If there are any staged then spread only those, otherwise spread all +unstaged changes. With a prefix argument use a transient command to +select infix arguments. + +This command requires the git-autofixup script, which is available from +https://github.com/torbiak/git-autofixup. See `magit-commit-absorb' for +an alternative implementation." + :value '("-vv") + ["Arguments" + (magit-autofixup:--context) + (magit-autofixup:--strict) + ("-v" "Increase verbosity" "-vv")] + ["Actions" + ("x" "Absorb" magit-commit-autofixup)] + (interactive (if current-prefix-arg + (list 'transient nil nil) + (list 'select + (magit-get-upstream-branch) + (transient-args 'magit-commit-autofixup)))) + (if (eq phase 'transient) + (transient-setup 'magit-commit-autofixup) + (unless (magit-git-executable-find "git-autofixup") + (user-error "This command requires the git-autofixup script, which %s" + "is available from https://github.com/torbiak/git-autofixup")) + (unless (magit-anything-modified-p) + (user-error "There are no changes that could be absorbed")) + (when commit + (setq commit (magit-rebase-interactive-assert commit t))) + (if (and commit (eq phase 'run)) + (progn (magit-run-git-async "autofixup" args commit) t) + (magit-log-select + (lambda (commit) + (with-no-warnings ; about non-interactive use + (magit-commit-autofixup 'run commit args))) + nil nil nil nil commit)))) + +(transient-augment-suffix magit-commit-autofixup :transient 'transient--do-exit) + +(transient-define-argument magit-autofixup:--context () + :description "Diff context lines" + :class 'transient-option + :shortarg "-c" + :argument "--context=" + :reader #'transient-read-number-N0) + +(transient-define-argument magit-autofixup:--strict () + :description "Strictness" + :class 'transient-option + :shortarg "-s" + :argument "--strict=" + :reader #'transient-read-number-N0) + +;;;; Hooks + +(defvar magit-post-commit-hook-commands + (list #'magit-commit-extend + #'magit-commit-fixup + #'magit-commit-augment + #'magit-commit-instant-fixup + #'magit-commit-instant-squash)) + +(defun magit-run-post-commit-hook () + (when (and (not this-command) + (memq last-command magit-post-commit-hook-commands)) + (run-hooks 'magit-post-commit-hook))) + +;;; Pending Diff + +(defun magit-commit-diff () + (magit-repository-local-set 'this-commit-command + (if (eq this-command 'with-editor-finish) + 'magit-commit--rebase + last-command)) + (when (and git-commit-mode magit-commit-show-diff) + (when-let ((diff-buffer (magit-get-mode-buffer 'magit-diff-mode))) + ;; This window just started displaying the commit message + ;; buffer. Without this that buffer would immediately be + ;; replaced with the diff buffer. See #2632. + (unrecord-window-buffer nil diff-buffer)) + (message "Diffing changes to be committed (C-g to abort diffing)") + (let ((inhibit-quit nil)) + (condition-case nil + (magit-commit-diff-1) + (quit))))) + +(defun magit-commit-diff-1 () + (let ((rev nil) + (arg "--cached") + (command (magit-repository-local-get 'this-commit-command)) + (staged (magit-anything-staged-p)) + (unstaged + ;; Escape $GIT_DIR because `magit-anything-unstaged-p' + ;; requires a working tree. + (magit-with-toplevel + (magit-anything-unstaged-p))) + (squash (let ((f (expand-file-name "rebase-merge/rewritten-pending" + (magit-gitdir)))) + (and (file-exists-p f) (length (magit-file-lines f))))) + (noalt nil)) + (pcase (list staged unstaged command) + ((and `(,_ ,_ magit-commit--rebase) + (guard (integerp squash))) + (setq rev (format "HEAD~%s" squash))) + (`(,_ ,_ magit-commit-amend) + (setq rev "HEAD^")) + (`(nil nil magit-commit--allow-empty) + (setq rev "HEAD") + (setq arg nil)) + ((or `(,_ ,_ magit-commit-reword) + `(nil nil ,_)) + (setq rev "HEAD^..HEAD") + (setq arg nil)) + (`(,_ t magit-commit--all) + (setq rev "HEAD") + (setq arg nil)) + (`(nil t handle-switch-frame) + ;; Either --all or --allow-empty. Assume it is the former. + (setq rev "HEAD") + (setq arg nil))) + (cond + ((not + (and (eq this-command 'magit-diff-while-committing) + (and-let* ((buf (magit-get-mode-buffer + 'magit-diff-mode nil 'selected))) + (and (equal rev (buffer-local-value 'magit-buffer-range buf)) + (equal arg (buffer-local-value 'magit-buffer-typearg buf))))))) + ((eq command 'magit-commit-amend) + (setq rev nil)) + ((or squash + (file-exists-p (expand-file-name "rebase-merge/amend" (magit-gitdir)))) + (setq rev "HEAD^")) + (t + (message "No alternative diff while committing") + (setq noalt t))) + (unless noalt + (let ((magit-inhibit-save-previous-winconf 'unset) + (magit-display-buffer-noselect t) + (display-buffer-overriding-action + display-buffer-overriding-action)) + (when magit-commit-diff-inhibit-same-window + (setq display-buffer-overriding-action + '(nil (inhibit-same-window . t)))) + (magit-diff-setup-buffer rev arg (car (magit-diff-arguments)) nil + (cond ((equal rev "HEAD") 'staged) + ((equal rev "HEAD^..HEAD") 'committed) + ('undefined))))))) + +(add-hook 'server-switch-hook #'magit-commit-diff) +(add-hook 'with-editor-filter-visit-hook #'magit-commit-diff) + +(add-to-list 'with-editor-server-window-alist + (cons git-commit-filename-regexp #'switch-to-buffer)) + +(defun magit-commit--reset-command () + (magit-repository-local-delete 'this-commit-command)) + +;;; Message Utilities + +(defun magit-commit-message-buffer () + (let* ((find-file-visit-truename t) ; git uses truename of COMMIT_EDITMSG + (topdir (magit-toplevel))) + (seq-find (##equal topdir (with-current-buffer % + (and git-commit-mode (magit-toplevel)))) + (append (buffer-list (selected-frame)) + (buffer-list))))) + +(defvar magit-commit-add-log-insert-function #'magit-commit-add-log-insert + "Used by `magit-commit-add-log' to insert a single entry.") + +(defun magit-commit-add-log () + "Add a stub for the current change into the commit message buffer. +If no commit is in progress, then initiate it. Use the function +specified by variable `magit-commit-add-log-insert-function' to +actually insert the entry." + (interactive) + (pcase-let* ((hunk (and (magit-section-match 'hunk) + (magit-current-section))) + (log (magit-commit-message-buffer)) + (`(,buf ,pos) (magit-diff-visit-file--noselect))) + (unless log + (unless (magit-commit-assert nil) + (user-error "Abort")) + (magit-commit-create) + (while (not (setq log (magit-commit-message-buffer))) + (sit-for 0.01))) + (magit--with-temp-position buf pos + (funcall magit-commit-add-log-insert-function log + (magit-file-relative-name) + (and hunk (add-log-current-defun)))))) + +(defun magit-commit-add-log-insert (buffer file defun) + (with-current-buffer buffer + (undo-boundary) + (goto-char (point-max)) + (while (re-search-backward (concat "^" comment-start) nil t)) + (save-restriction + (narrow-to-region (point-min) (point)) + (cond ((re-search-backward (format "* %s\\(?: (\\([^)]+\\))\\)?: " file) + nil t) + (when (equal (match-string 1) defun) + (setq defun nil)) + (re-search-forward ": ")) + (t + (when (re-search-backward "^[\\*(].+\n" nil t) + (goto-char (match-end 0))) + (while (re-search-forward "^[^\\*\n].*\n" nil t)) + (if defun + (progn (insert (format "* %s (%s): \n" file defun)) + (setq defun nil)) + (insert (format "* %s: \n" file))) + (backward-char) + (unless (looking-at "\n[\n\\']") + (insert ?\n) + (backward-char)))) + (when defun + (forward-line) + (let ((limit (save-excursion + (and (re-search-forward "^\\*" nil t) + (point))))) + (unless (or (looking-back (format "(%s): " defun) + (line-beginning-position)) + (re-search-forward (format "^(%s): " defun) limit t)) + (while (re-search-forward "^[^\\*\n].*\n" limit t)) + (insert (format "(%s): \n" defun)) + (backward-char))))))) + +;;; _ +(provide 'magit-commit) +;;; magit-commit.el ends here blob - /dev/null blob + a7ff47e7579d091ee2aa033ff6df08b65555a9cd (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-core.el @@ -0,0 +1,123 @@ +;;; magit-core.el --- Core functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library requires several other libraries, so that yet other +;; libraries can just require this one, instead of having to require +;; all the other ones. In other words this separates the low-level +;; stuff from the rest. It also defines some Custom groups. + +;;; Code: + +(require 'magit-base) +(require 'magit-git) +(require 'magit-mode) +(require 'magit-margin) +(require 'magit-process) +(require 'magit-transient) +(require 'magit-autorevert) + +;;; Options + +(defgroup magit nil + "Controlling Git from Emacs." + :link '(url-link "https://magit.vc") + :link '(info-link "(magit)FAQ") + :link '(info-link "(magit)") + :group 'tools) + +(defgroup magit-essentials nil + "Options that every Magit user should briefly think about. + +Each of these options falls into one or more of these categories: + +* Options that affect Magit's behavior in fundamental ways. +* Options that affect safety. +* Options that affect performance. +* Options that are of a personal nature." + :link '(info-link "(magit)Essential Settings") + :group 'magit) + +(defgroup magit-miscellaneous nil + "Miscellaneous Magit options." + :group 'magit) + +(defgroup magit-commands nil + "Options controlling behavior of certain commands." + :group 'magit) + +(defgroup magit-modes nil + "Modes used or provided by Magit." + :group 'magit) + +(defgroup magit-buffers nil + "Options concerning Magit buffers." + :link '(info-link "(magit)Modes and Buffers") + :group 'magit) + +(defgroup magit-refresh nil + "Options controlling how Magit buffers are refreshed." + :link '(info-link "(magit)Automatic Refreshing of Magit Buffers") + :group 'magit + :group 'magit-buffers) + +(defgroup magit-faces nil + "Faces used by Magit." + :group 'magit + :group 'faces) + +(custom-add-to-group 'magit-faces 'diff-refine-added 'custom-face) +(custom-add-to-group 'magit-faces 'diff-refine-removed 'custom-face) + +(defgroup magit-extensions nil + "Extensions to Magit." + :group 'magit) + +(custom-add-to-group 'magit-modes 'git-commit 'custom-group) +(custom-add-to-group 'magit-faces 'git-commit-faces 'custom-group) +(custom-add-to-group 'magit-modes 'git-rebase 'custom-group) +(custom-add-to-group 'magit-faces 'git-rebase-faces 'custom-group) +(custom-add-to-group 'magit 'magit-section 'custom-group) +(custom-add-to-group 'magit-faces 'magit-section-faces 'custom-group) +(custom-add-to-group 'magit-process 'with-editor 'custom-group) + +(defgroup magit-related nil + "Options that are relevant to Magit but that are defined elsewhere." + :link '(custom-group-link vc) + :link '(custom-group-link smerge) + :link '(custom-group-link ediff) + :link '(custom-group-link auto-revert) + :group 'magit + :group 'magit-extensions + :group 'magit-essentials) + +(custom-add-to-group 'magit-related 'auto-revert-check-vc-info 'custom-variable) +(custom-add-to-group 'magit-auto-revert 'auto-revert-check-vc-info 'custom-variable) + +(custom-add-to-group 'magit-related 'ediff-window-setup-function 'custom-variable) +(custom-add-to-group 'magit-related 'smerge-refine-ignore-whitespace 'custom-variable) +(custom-add-to-group 'magit-related 'vc-follow-symlinks 'custom-variable) + +;;; _ +(provide 'magit-core) +;;; magit-core.el ends here blob - /dev/null blob + 3a9faaf1d9fda2099069682aa02c2bd1ed1bc214 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-diff.el @@ -0,0 +1,3594 @@ +;;; magit-diff.el --- Inspect Git diffs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for looking at Git diffs and +;; commits. + +;;; Code: + +(require 'magit-core) +(require 'git-commit) + +(eval-when-compile (require 'ansi-color)) +(require 'diff-mode) +(require 'image) +(require 'smerge-mode) + +;; For `magit-diff-popup' +(declare-function magit-stash-show "magit-stash" (stash &optional args files)) +;; For `magit-diff-visit-file' +(declare-function magit-find-file-noselect "magit-files" (rev file)) +(declare-function magit-status-setup-buffer "magit-status" (&optional directory)) +;; For `magit-diff-while-committing' +(declare-function magit-commit-diff-1 "magit-commit" ()) +(declare-function magit-commit-message-buffer "magit-commit" ()) +;; For `magit-insert-revision-gravatar' +(defvar gravatar-size) +;; For `magit-show-commit' and `magit-diff-show-or-scroll' +(declare-function magit-current-blame-chunk "magit-blame" (&optional type noerror)) +(declare-function magit-blame-mode "magit-blame" (&optional arg)) +(defvar magit-blame-mode) +;; For `magit-diff-show-or-scroll' +(declare-function git-rebase-current-line "git-rebase" (&optional batch)) +;; For `magit-diff-unmerged' +(declare-function magit-merge-in-progress-p "magit-merge" ()) +(declare-function magit--merge-range "magit-merge" (&optional head)) +;; For `magit-diff--dwim' +(declare-function forge--pullreq-range "ext:forge-pullreq" + (pullreq &optional endpoints)) +(declare-function forge--pullreq-ref "ext:forge-pullreq" (pullreq)) +;; For `magit-diff-wash-diff' +(declare-function ansi-color-apply-on-region "ansi-color") +;; For `magit-diff-wash-submodule' +(declare-function magit-log-wash-log "magit-log" (style args)) +;; For keymaps and menus +(declare-function magit-apply "magit-apply" (&rest args)) +(declare-function magit-stage "magit-apply" (&optional indent)) +(declare-function magit-unstage "magit-apply" ()) +(declare-function magit-discard "magit-apply" ()) +(declare-function magit-reverse "magit-apply" (&rest args)) +(declare-function magit-file-rename "magit-files" (file newname)) +(declare-function magit-file-untrack "magit-files" (files &optional force)) +(declare-function magit-commit-add-log "magit-commit" ()) +(declare-function magit-diff-trace-definition "magit-log" ()) +(declare-function magit-patch-save "magit-patch" (files &optional arg)) +(declare-function magit-do-async-shell-command "magit-dired" (file)) +(declare-function magit-add-change-log-entry "magit-extras" + (&optional whoami file-name other-window)) +(declare-function magit-add-change-log-entry-other-window "magit-extras" + (&optional whoami file-name)) +(declare-function magit-diff-edit-hunk-commit "magit-extras" (file)) +(declare-function magit-smerge-keep-current "magit-apply" ()) +(declare-function magit-smerge-keep-all "magit-apply" ()) +(declare-function magit-smerge-keep-upper "magit-apply" ()) +(declare-function magit-smerge-keep-base "magit-apply" ()) +(declare-function magit-smerge-keep-lower "magit-apply" ()) + +(eval-when-compile + (cl-pushnew 'orig-rev eieio--known-slot-names) + (cl-pushnew 'action-type eieio--known-slot-names) + (cl-pushnew 'target eieio--known-slot-names)) + +(define-obsolete-variable-alias 'magit-diff-section-base-map + 'magit-diff-section-map "Magit 4.0.0") + +(define-obsolete-variable-alias 'magit-wash-message-hook + 'magit-revision-wash-message-hook "Magit 4.3.0") + +(make-obsolete-variable 'magit-diff-highlight-keywords + 'magit-revision-wash-message-hook + "Magit 4.3.0") + +;;; Options +;;;; Diff Mode + +(defgroup magit-diff nil + "Inspect and manipulate Git diffs." + :link '(info-link "(magit)Diffing") + :group 'magit-commands + :group 'magit-modes) + +(defcustom magit-diff-mode-hook nil + "Hook run after entering Magit-Diff mode." + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-sections-hook + (list #'magit-insert-diff + #'magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-diff-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-diff + :type 'hook) + +(defcustom magit-diff-expansion-threshold 60 + "After how many seconds not to expand anymore diffs. + +Except in status buffers, diffs usually start out fully expanded. +Because that can take a long time, all diffs that haven't been +fontified during a refresh before the threshold defined here are +instead displayed with their bodies collapsed. + +Note that this can cause sections that were previously expanded +to be collapsed. So you should not pick a very low value here. + +The hook function `magit-diff-expansion-threshold' has to be a +member of `magit-section-set-visibility-hook' for this option +to have any effect." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'float) + +(defcustom magit-diff-highlight-hunk-body t + "Whether to highlight bodies of selected hunk sections." + :package-version '(magit . "2.1.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-highlight-hunk-region-functions + (list #'magit-diff-highlight-hunk-region-dim-outside + #'magit-diff-highlight-hunk-region-using-overlays) + "The functions used to highlight the hunk-internal region. + +`magit-diff-highlight-hunk-region-dim-outside' overlays the outside +of the hunk internal selection with a face that causes the added and +removed lines to have the same background color as context lines. +This function should not be removed from the value of this option. + +`magit-diff-highlight-hunk-region-using-overlays' and +`magit-diff-highlight-hunk-region-using-underline' emphasize the +region by placing delimiting horizontal lines before and after it. +The underline variant was implemented because Eli said that is +how we should do it. However the overlay variant actually works +better. Also see https://github.com/magit/magit/issues/2758. + +Instead of, or in addition to, using delimiting horizontal lines, +to emphasize the boundaries, you may wish to emphasize the text +itself, using `magit-diff-highlight-hunk-region-using-face'. + +In terminal frames it's not possible to draw lines as the overlay +and underline variants normally do, so there they fall back to +calling the face function instead." + :package-version '(magit . "2.9.0") + :set-after '(magit-diff-show-lines-boundaries) + :group 'magit-diff + :type 'hook + :options (list #'magit-diff-highlight-hunk-region-dim-outside + #'magit-diff-highlight-hunk-region-using-underline + #'magit-diff-highlight-hunk-region-using-overlays + #'magit-diff-highlight-hunk-region-using-face)) + +(defcustom magit-diff-unmarked-lines-keep-foreground t + "Whether `magit-diff-highlight-hunk-region-dim-outside' preserves foreground. +When this is set to nil, then that function only adjusts the +foreground color but added and removed lines outside the region +keep their distinct foreground colors." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-refine-hunk nil + "Whether to show word-granularity differences within diff hunks. + +`nil' Never show fine differences. +`all' Show fine differences for all displayed diff hunks. +`t' Refine each hunk once it becomes the current section. + Keep the refinement when another section is selected. + Refreshing the buffer removes all refinement. This + variant is only provided for performance reasons." + :group 'magit-diff + :safe (##memq % '(nil t all)) + :type '(choice (const :tag "No refinement" nil) + (const :tag "Immediately refine all hunks" all) + (const :tag "Refine each hunk when moving to it" t))) + +(defcustom magit-diff-refine-ignore-whitespace smerge-refine-ignore-whitespace + "Whether to ignore whitespace changes in word-granularity differences." + :package-version '(magit . "3.0.0") + :set-after '(smerge-refine-ignore-whitespace) + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(put 'magit-diff-refine-hunk 'permanent-local t) + +(defcustom magit-diff-adjust-tab-width nil + "Whether to adjust the width of tabs in diffs. + +Determining the correct width can be expensive if it requires +opening large and/or many files, so the widths are cached in +the variable `magit-diff--tab-width-cache'. Set that to `nil' +to invalidate the cache. + +`nil' Never adjust tab width. Use `tab-width's value from + the Magit buffer itself instead. + +`t' If the corresponding file-visiting buffer exits, then + use `tab-width's value from that buffer. Doing this is + cheap, so this value is used even if a corresponding + cache entry exists. + +`always' If there is no such buffer, then temporarily visit the + file to determine the value. + +NUMBER Like `always', but don't visit files larger than NUMBER + bytes." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type '(choice (const :tag "Never" nil) + (const :tag "If file-visiting buffer exists" t) + (integer :tag "If file isn't larger than N bytes") + (const :tag "Always" always))) + +(defcustom magit-diff-paint-whitespace t + "Specify where to highlight whitespace errors. + +`nil' Never highlight whitespace errors. +`t' Highlight whitespace errors everywhere. +`uncommitted' Only highlight whitespace errors in diffs + showing uncommitted changes. + +For backward compatibility `status' is treated as a synonym +for `uncommitted'. + +The option `magit-diff-paint-whitespace-lines' controls for +what lines (added/remove/context) errors are highlighted. + +The options `magit-diff-highlight-trailing' and +`magit-diff-highlight-indentation' control what kind of +whitespace errors are highlighted." + :group 'magit-diff + :safe (##memq % '(t nil uncommitted status)) + :type '(choice (const :tag "In all diffs" t) + (const :tag "Only in uncommitted changes" uncommitted) + (const :tag "Never" nil))) + +(defcustom magit-diff-paint-whitespace-lines t + "Specify in what kind of lines to highlight whitespace errors. + +`t' Highlight only in added lines. +`both' Highlight in added and removed lines. +`all' Highlight in added, removed and context lines." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :safe (##memq % '(t both all)) + :type '(choice (const :tag "In added lines" t) + (const :tag "In added and removed lines" both) + (const :tag "In added, removed and context lines" all))) + +(defcustom magit-diff-highlight-trailing t + "Whether to highlight whitespace at the end of a line in diffs. +Used only when `magit-diff-paint-whitespace' is non-nil." + :group 'magit-diff + :safe 'booleanp + :type 'boolean) + +(defcustom magit-diff-highlight-indentation nil + "Highlight the \"wrong\" indentation style. +Used only when `magit-diff-paint-whitespace' is non-nil. + +The value is an alist of the form ((REGEXP . INDENT)...). The +path to the current repository is matched against each element +in reverse order. Therefore if a REGEXP matches, then earlier +elements are not tried. + +If the used INDENT is `tabs', highlight indentation with tabs. +If INDENT is an integer, highlight indentation with at least +that many spaces. Otherwise, highlight neither." + :group 'magit-diff + :type `(repeat (cons (string :tag "Directory regexp") + (choice (const :tag "Tabs" tabs) + (integer :tag "Spaces" :value ,tab-width) + (const :tag "Neither" nil))))) + +(defcustom magit-diff-hide-trailing-cr-characters + (and (memq system-type '(ms-dos windows-nt)) t) + "Whether to hide ^M characters at the end of a line in diffs." + :package-version '(magit . "2.6.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-extra-stat-arguments nil + "Additional arguments to be used alongside `--stat'. + +A list of zero or more arguments or a function that takes no +argument and returns such a list. These arguments are allowed +here: `--stat-width', `--stat-name-width', `--stat-graph-width' +and `--compact-summary'. See the git-diff(1) manpage." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :type `(radio (function-item ,#'magit-diff-use-window-width-as-stat-width) + function + (list string) + (const :tag "None" nil))) + +(defcustom magit-format-file-function #'magit-format-file-default + "Function used to format lines representing a file. + +This function is used for file headings in diffs, in diffstats and for +lists of files (such as the untracked files). Depending on the caller, +it receives either three or five arguments; the signature has to be +\(kind file face &optional status orig). KIND is one of `diff', +`module', `stat' and `list'." + :package-version '(magit . "4.3.1") + :group 'magit-diff + :type `(radio (function-item ,#'magit-format-file-default) + (function-item ,#'magit-format-file-all-the-icons) + (function-item ,#'magit-format-file-nerd-icons) + function)) + +;;;; File Diff + +(defcustom magit-diff-buffer-file-locked t + "Whether `magit-diff-buffer-file' uses a dedicated buffer." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :group 'magit-diff + :type 'boolean) + +;;;; Revision Mode + +(defgroup magit-revision nil + "Inspect and manipulate Git commits." + :link '(info-link "(magit)Revision Buffer") + :group 'magit-modes) + +(defcustom magit-revision-mode-hook + (list #'bug-reference-mode + #'goto-address-mode) + "Hook run after entering Magit-Revision mode." + :group 'magit-revision + :type 'hook + :options '(bug-reference-mode + goto-address-mode)) + +(defcustom magit-revision-sections-hook + (list #'magit-insert-revision-tag + #'magit-insert-revision-headers + #'magit-insert-revision-message + #'magit-insert-revision-notes + #'magit-insert-revision-diff + #'magit-insert-xref-buttons) + "Hook run to insert sections into a `magit-revision-mode' buffer." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'hook) + +(defcustom magit-revision-wash-message-hook + (list #'magit-highlight-squash-markers + #'magit-highlight-bracket-keywords) + "Functions used to highlight parts of a commit message. + +These functions are called in order, in a buffer narrowed to the commit +message. They should set text properties as they see fit, usually just +`font-lock-face'. Before each function is called, point is at the +beginning of the narrowed region of the buffer. + +See also the related `magit-log-wash-summary-hook'. You likely want to +use the same functions for both hooks." + :package-version '(magit . "4.3.0") + :group 'magit-log + :type 'hook + :options (list #'magit-highlight-squash-markers + #'magit-highlight-bracket-keywords)) + +(defcustom magit-revision-headers-format "\ +Author: %aN <%aE> +AuthorDate: %ad +Commit: %cN <%cE> +CommitDate: %cd +" + "Format string used to insert headers in revision buffers. + +All headers in revision buffers are inserted by the section +inserter `magit-insert-revision-headers'. Some of the headers +are created by calling `git show --format=FORMAT' where FORMAT +is the format specified here. Other headers are hard coded or +subject to option `magit-revision-insert-related-refs'." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type 'string) + +(defcustom magit-revision-insert-related-refs t + "Whether to show related branches in revision buffers. + +`nil' Don't show any related branches. +`t' Show related local branches. +`all' Show related local and remote branches. +`mixed' Show all containing branches and local merged branches. + +See user option `magit-revision-insert-related-refs-display-alist' +to hide specific sets of related branches." + :package-version '(magit . "2.1.0") + :group 'magit-revision + :type '(choice (const :tag "Do not" nil) + (const :tag "Local only" t) + (const :tag "All related" all) + (const :tag "All containing, local merged" mixed))) + +(defcustom magit-revision-insert-related-refs-display-alist nil + "How `magit-insert-revision-headers' displays related branch types. + +This is an alist, with recognised keys being the symbols +`parents', `merged', `contained', `follows', and `precedes'; +and the supported values for each key being: + +`nil' Hide these related branches. +`t' Show these related branches. + +Keys which are not present in the alist have an implicit value `t' +\(so the default alist value of `nil' means all related branch types +will be shown.) + +The types to be shown are additionally subject to user option +`magit-revision-insert-related-refs'." + :package-version '(magit . "3.3.1") + :group 'magit-revision + :type '(alist :key-type (symbol :tag "Type of related branch") + :value-type (boolean :tag "Display")) + :options (mapcar (lambda (sym) + `(,sym (choice (const :tag "Hide" nil) + (const :tag "Show" t)))) + '(parents merged contained follows precedes))) + +(defcustom magit-revision-use-hash-sections 'quicker + "Whether to turn hashes inside the commit message into sections. + +If non-nil, then hashes inside the commit message are turned into +`commit' sections. There is a trade off to be made between +performance and reliability: + +- `slow' calls git for every word to be absolutely sure. +- `quick' skips words less than seven characters long. +- `quicker' additionally skips words that don't contain a number. +- `quickest' uses all words that are at least seven characters + long and which contain at least one number as well as at least + one letter. + +If `nil', then no hashes are turned into sections, but you can +still visit the commit at point using \"RET\"." + :package-version '(magit . "2.12.0") + :group 'magit-revision + :type '(choice (const :tag "Use sections, quickest" quickest) + (const :tag "Use sections, quicker" quicker) + (const :tag "Use sections, quick" quick) + (const :tag "Use sections, slow" slow) + (const :tag "Don't use sections" nil))) + +(defcustom magit-revision-show-gravatars nil + "Whether to show gravatar images in revision buffers. + +If `nil', then don't insert any gravatar images. If `t', then +insert both images. If `author' or `committer', then insert +only the respective image. + +If you have customized the option `magit-revision-header-format' +and want to insert the images then you might also have to specify +where to do so. In that case the value has to be a cons-cell of +two regular expressions. The car specifies where to insert the +author's image. The top half of the image is inserted right +after the matched text, the bottom half on the next line in the +same column. The cdr specifies where to insert the committer's +image, accordingly. Either the car or the cdr may be `nil'." + :package-version '(magit . "2.3.0") + :group 'magit-revision + :type '(choice + (const :tag "Don't show gravatars" nil) + (const :tag "Show gravatars" t) + (const :tag "Show author gravatar" author) + (const :tag "Show committer gravatar" committer) + (cons :tag "Show gravatars using custom regexps" + (choice (const :tag "No author image" nil) + (regexp :tag "Author regexp" "^Author: ")) + (choice (const :tag "No committer image" nil) + (regexp :tag "Committer regexp" "^Commit: "))))) + +(defcustom magit-revision-fill-summary-line nil + "Whether to fill excessively long summary lines. + +If this is an integer, then the summary line is filled if it is +longer than either the limit specified here or `window-width'. + +You may want to only set this locally in \".dir-locals-2.el\" for +repositories known to contain bad commit messages. + +The body of the message is left alone because (a) most people who +write excessively long summary lines usually don't add a body and +\(b) even people who have the decency to wrap their lines may have +a good reason to include a long line in the body sometimes." + :package-version '(magit . "2.90.0") + :group 'magit-revision + :type '(choice (const :tag "Don't fill" nil) + (integer :tag "Fill if longer than"))) + +(defcustom magit-revision-filter-files-on-follow nil + "Whether to honor file filter if log arguments include --follow. + +When a commit is displayed from a log buffer, the resulting +revision buffer usually shares the log's file arguments, +restricting the diff to those files. However, there's a +complication when the log arguments include --follow: if the log +follows a file across a rename event, keeping the file +restriction would mean showing an empty diff in revision buffers +for commits before the rename event. + +When this option is nil, the revision buffer ignores the log's +filter if the log arguments include --follow. If non-nil, the +log's file filter is always honored." + :package-version '(magit . "3.0.0") + :group 'magit-revision + :type 'boolean) + +;;;; Visit Commands + +(defcustom magit-diff-visit-previous-blob t + "Whether `magit-diff-visit-file' may visit the previous blob. + +When this is t and point is on a removed line in a diff for a +committed change, then `magit-diff-visit-file' visits the blob +from the last revision which still had that line. + +Currently this is only supported for committed changes, for +staged and unstaged changes `magit-diff-visit-file' always +visits the file in the working tree." + :package-version '(magit . "2.9.0") + :group 'magit-diff + :type 'boolean) + +(defcustom magit-diff-visit-avoid-head-blob nil + "Whether `magit-diff-visit-file' avoids visiting a blob from `HEAD'. + +By default `magit-diff-visit-file' always visits the blob that +added the current line, while `magit-diff-visit-worktree-file' +visits the respective file in the working tree. For the `HEAD' +commit, the former command used to visit the worktree file too, +but that made it impossible to visit a blob from `HEAD'. + +When point is on a removed line and that change has not been +committed yet, then `magit-diff-visit-file' now visits the last +blob that still had that line, which is a blob from `HEAD'. +Previously this function used to visit the worktree file not +only for added lines but also for such removed lines. + +If you prefer the old behaviors, then set this to t." + :package-version '(magit . "3.0.0") + :group 'magit-diff + :type 'boolean) + +;;; Faces + +(defface magit-diff-file-heading + '((t :extend t :weight bold)) + "Face for diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-highlight + '((t :extend t :inherit magit-section-highlight)) + "Face for current diff file headings." + :group 'magit-faces) + +(defface magit-diff-file-heading-selection + '((((class color) (background light)) + :extend t + :inherit magit-diff-file-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + :extend t + :inherit magit-diff-file-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff file headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading + '((((class color) (background light)) + :extend t + :background "grey90" + :foreground "grey20") + (((class color) (background dark)) + :extend t + :background "grey25" + :foreground "grey95")) + "Face for diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-highlight + '((((class color) (background light)) + :extend t + :background "grey80" + :foreground "grey20") + (((class color) (background dark)) + :extend t + :background "grey35" + :foreground "grey95")) + "Face for current diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-heading-selection + '((((class color) (background light)) + :extend t + :inherit magit-diff-hunk-heading-highlight + :foreground "salmon4") + (((class color) (background dark)) + :extend t + :inherit magit-diff-hunk-heading-highlight + :foreground "LightSalmon3")) + "Face for selected diff hunk headings." + :group 'magit-faces) + +(defface magit-diff-hunk-region + `((t :inherit bold + :extend ,(ignore-errors (face-attribute 'region :extend)))) + "Face used by `magit-diff-highlight-hunk-region-using-face'. + +This face is overlaid over text that uses other hunk faces, +and those normally set the foreground and background colors. +The `:foreground' and especially the `:background' properties +should be avoided here. Setting the latter would cause the +loss of information. Good properties to set here are `:weight' +and `:slant'." + :group 'magit-faces) + +(defface magit-diff-revision-summary + '((t :inherit magit-diff-hunk-heading)) + "Face for commit message summaries." + :group 'magit-faces) + +(defface magit-diff-revision-summary-highlight + '((t :inherit magit-diff-hunk-heading-highlight)) + "Face for highlighted commit message summaries." + :group 'magit-faces) + +(defface magit-diff-lines-heading + '((((class color) (background light)) + :extend t + :inherit magit-diff-hunk-heading-highlight + :background "LightSalmon3") + (((class color) (background dark)) + :extend t + :inherit magit-diff-hunk-heading-highlight + :foreground "grey80" + :background "salmon4")) + "Face for diff hunk heading when lines are marked." + :group 'magit-faces) + +(defface magit-diff-lines-boundary + '((t :extend t :inherit magit-diff-lines-heading)) + "Face for boundary of marked lines in diff hunk." + :group 'magit-faces) + +(defface magit-diff-conflict-heading + '((t :inherit magit-diff-hunk-heading)) + "Face for conflict markers." + :group 'magit-faces) + +(defface magit-diff-added + '((((class color) (background light)) + :extend t + :background "#ddffdd" + :foreground "#22aa22") + (((class color) (background dark)) + :extend t + :background "#335533" + :foreground "#ddffdd")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed + '((((class color) (background light)) + :extend t + :background "#ffdddd" + :foreground "#aa2222") + (((class color) (background dark)) + :extend t + :background "#553333" + :foreground "#ffdddd")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our + '((t :inherit magit-diff-removed)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base + '((((class color) (background light)) + :extend t + :background "#ffffcc" + :foreground "#aaaa11") + (((class color) (background dark)) + :extend t + :background "#555522" + :foreground "#ffffcc")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their + '((t :inherit magit-diff-added)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context + '((((class color) (background light)) + :extend t + :foreground "grey50") + (((class color) (background dark)) + :extend t + :foreground "grey70")) + "Face for lines in a diff that are unchanged." + :group 'magit-faces) + +(defface magit-diff-added-highlight + '((((class color) (background light)) + :extend t + :background "#cceecc" + :foreground "#22aa22") + (((class color) (background dark)) + :extend t + :background "#336633" + :foreground "#cceecc")) + "Face for lines in a diff that have been added." + :group 'magit-faces) + +(defface magit-diff-removed-highlight + '((((class color) (background light)) + :extend t + :background "#eecccc" + :foreground "#aa2222") + (((class color) (background dark)) + :extend t + :background "#663333" + :foreground "#eecccc")) + "Face for lines in a diff that have been removed." + :group 'magit-faces) + +(defface magit-diff-our-highlight + '((t :inherit magit-diff-removed-highlight)) + "Face for lines in a diff for our side in a conflict." + :group 'magit-faces) + +(defface magit-diff-base-highlight + '((((class color) (background light)) + :extend t + :background "#eeeebb" + :foreground "#aaaa11") + (((class color) (background dark)) + :extend t + :background "#666622" + :foreground "#eeeebb")) + "Face for lines in a diff for the base side in a conflict." + :group 'magit-faces) + +(defface magit-diff-their-highlight + '((t :inherit magit-diff-added-highlight)) + "Face for lines in a diff for their side in a conflict." + :group 'magit-faces) + +(defface magit-diff-context-highlight + '((((class color) (background light)) + :extend t + :background "grey95" + :foreground "grey50") + (((class color) (background dark)) + :extend t + :background "grey20" + :foreground "grey70")) + "Face for lines in the current context in a diff." + :group 'magit-faces) + +(defface magit-diff-whitespace-warning + '((t :inherit trailing-whitespace)) + "Face for highlighting whitespace errors added lines." + :group 'magit-faces) + +(defface magit-diffstat-added + '((((class color) (background light)) :foreground "#22aa22") + (((class color) (background dark)) :foreground "#448844")) + "Face for plus sign in diffstat." + :group 'magit-faces) + +(defface magit-diffstat-removed + '((((class color) (background light)) :foreground "#aa2222") + (((class color) (background dark)) :foreground "#aa4444")) + "Face for minus sign in diffstat." + :group 'magit-faces) + +;;; Arguments +;;;; Prefix Classes + +(defclass magit-diff-prefix (transient-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform 'magit-diff-mode))) + +(defclass magit-diff-refresh-prefix (magit-diff-prefix) + ((history-key :initform 'magit-diff) + (major-mode :initform nil))) + +;;;; Prefix Methods + +(cl-defmethod transient-init-value ((obj magit-diff-prefix)) + (pcase-let ((`(,args ,files) + (magit-diff--get-value 'magit-diff-mode + magit-prefix-use-buffer-arguments))) + (when-let (((not (eq transient-current-command 'magit-dispatch))) + (file (magit-file-relative-name))) + (setq files (list file))) + (oset obj value (if files `(("--" ,@files) ,@args) args)))) + +(cl-defmethod transient-init-value ((obj magit-diff-refresh-prefix)) + (oset obj value (if magit-buffer-diff-files + `(("--" ,@magit-buffer-diff-files) + ,@magit-buffer-diff-args) + magit-buffer-diff-args))) + +(cl-defmethod transient-set-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj)) + +(cl-defmethod transient-save-value ((obj magit-diff-prefix)) + (magit-diff--set-value obj 'save)) + +;;;; Argument Access + +(defun magit-diff-arguments (&optional mode) + "Return the current diff arguments." + (if (memq transient-current-command '(magit-diff magit-diff-refresh)) + (magit--transient-args-and-files) + (magit-diff--get-value (or mode 'magit-diff-mode)))) + +(defun magit-diff--get-value (mode &optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args files) + (cond + ((and (memq use-buffer-args '(always selected current)) + (eq major-mode mode)) + (setq args magit-buffer-diff-args) + (setq files magit-buffer-diff-files)) + ((when-let (((memq use-buffer-args '(always selected))) + (buffer (magit-get-mode-buffer + mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-diff-args buffer)) + (setq files (buffer-local-value 'magit-buffer-diff-files buffer)) + t)) + ((plist-member (symbol-plist mode) 'magit-diff-current-arguments) + (setq args (get mode 'magit-diff-current-arguments))) + ((when-let ((elt (assq (intern (format "magit-diff:%s" mode)) + transient-values))) + (setq args (cdr elt)) + t)) + (t + (setq args (get mode 'magit-diff-default-arguments)))) + (list args files))) + +(defun magit-diff--set-value (obj &optional save) + (pcase-let* ((obj (oref obj prototype)) + (mode (or (oref obj major-mode) major-mode)) + (key (intern (format "magit-diff:%s" mode))) + (`(,args ,files) (magit--transient-args-and-files))) + (put mode 'magit-diff-current-arguments args) + (when save + (setf (alist-get key transient-values) args) + (transient-save-values)) + (transient--history-push obj) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files) + (magit-refresh))) + +;;; Commands +;;;; Prefix Commands + +(transient-define-group magit-diff-infix-arguments + ["Limit arguments" + (magit:--) + (magit-diff:--ignore-submodules) + ("-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + ("-w" "Ignore all whitespace" ("-w" "--ignore-all-space")) + ("-D" "Omit preimage for deletes" ("-D" "--irreversible-delete") + :level 5)] + ["Context arguments" + (magit-diff:-U) + ("-W" "Show surrounding functions" ("-W" "--function-context"))] + ["Tune arguments" + (magit-diff:--diff-algorithm) + (magit-diff:--diff-merges) + (magit-diff:-M) + (magit-diff:-C) + (magit-diff:-R :level 5) + (magit-diff:--color-moved :level 5) + (magit-diff:--color-moved-ws :level 5) + (magit-diff:--no-ext-diff) + (magit-diff:--stat) + (magit-diff:--show-signature)]) + +;;;###autoload (autoload 'magit-diff "magit-diff" nil t) +(transient-define-prefix magit-diff () + "Show changes between different versions." + :man-page "git-diff" + :class 'magit-diff-prefix + 'magit-diff-infix-arguments + ["Actions" + [("d" "Dwim" magit-diff-dwim) + ("r" "Diff range" magit-diff-range) + ("p" "Diff paths" magit-diff-paths)] + [("u" "Diff unstaged" magit-diff-unstaged) + ("s" "Diff staged" magit-diff-staged) + ("w" "Diff worktree" magit-diff-working-tree)] + [("c" "Show commit" magit-show-commit) + ("t" "Show stash" magit-stash-show)]]) + +;;;###autoload (autoload 'magit-diff-refresh "magit-diff" nil t) +(transient-define-prefix magit-diff-refresh () + "Change the arguments used for the diff(s) in the current buffer." + :man-page "git-diff" + :class 'magit-diff-refresh-prefix + 'magit-diff-infix-arguments + [["Refresh" + ("g" "buffer" magit-diff-refresh) + ("s" "buffer and set defaults" transient-set-and-exit) + ("w" "buffer and save defaults" transient-save-and-exit)] + ["Toggle" + ("t" "hunk refinement" magit-diff-toggle-refine-hunk) + ("F" "file filter" magit-diff-toggle-file-filter) + ("b" "buffer lock" magit-toggle-buffer-lock + :if-mode (magit-diff-mode magit-revision-mode magit-stash-mode))] + [:if-mode magit-diff-mode + :description "Do" + ("r" "switch range type" magit-diff-switch-range-type) + ("f" "flip revisions" magit-diff-flip-revs)]] + (interactive) + (when (derived-mode-p 'magit-merge-preview-mode) + (user-error "Cannot use %s in %s" this-command major-mode)) + (if (not (eq transient-current-command 'magit-diff-refresh)) + (transient-setup 'magit-diff-refresh) + (pcase-let ((`(,args ,files) (magit-diff-arguments))) + (setq magit-buffer-diff-args args) + (setq magit-buffer-diff-files files)) + (magit-refresh))) + +;;;; Infix Commands + +(transient-define-argument magit:-- () + :description "Limit to files" + :class 'transient-files + :key "--" + :argument "--" + :prompt "Limit to file,s: " + :reader #'magit-read-files + :multi-value t) + +(defun magit-read-files (prompt initial-input history &optional list-fn) + (magit-with-toplevel + (magit-completing-read-multiple prompt + (funcall (or list-fn #'magit-list-files)) + nil nil + (or initial-input (magit-file-at-point)) + history))) + +(transient-define-argument magit-diff:-U () + :description "Context lines" + :class 'transient-option + :argument "-U" + :reader #'transient-read-number-N0) + +(transient-define-argument magit-diff:-M () + :description "Detect renames" + :class 'transient-option + :argument "-M" + :allow-empty t + :reader #'transient-read-number-N+) + +(transient-define-argument magit-diff:-C () + :description "Detect copies" + :class 'transient-option + :argument "-C" + :allow-empty t + :reader #'transient-read-number-N+) + +(transient-define-argument magit-diff:--diff-algorithm () + :description "Diff algorithm" + :class 'transient-option + :key "-A" + :argument "--diff-algorithm=" + :reader #'magit-diff-select-algorithm + :always-read t) + +(defun magit-diff-select-algorithm (&rest _ignore) + (magit-read-char-case nil t + (?u "[u]nspecified" nil) + (?d "[d]efault" "default") + (?m "[m]inimal" "minimal") + (?p "[p]atience" "patience") + (?h "[h]istogram" "histogram"))) + +(transient-define-argument magit-diff:--diff-merges () + :description "Diff merges" + :class 'transient-option + :key "-X" + :argument "--diff-merges=" + :reader #'magit-diff-select-merges + :always-read t) + +(defun magit-diff-select-merges (&rest _ignore) + (magit-read-char-case nil t + (?u "[u]nspecified" nil) + (?o "[o]ff" "off") + (?f "[f]irst-parent" "first-parent") + (?c "[c]ombined" "combined") + (?d "[d]ense-combined" "dense-combined"))) + +(transient-define-argument magit-diff:--ignore-submodules () + :description "Ignore submodules" + :class 'transient-option + :key "-i" + :argument "--ignore-submodules=" + :reader #'magit-diff-select-ignore-submodules) + +(defun magit-diff-select-ignore-submodules (&rest _ignored) + (magit-read-char-case "Ignore submodules " t + (?u "[u]ntracked" "untracked") + (?d "[d]irty" "dirty") + (?a "[a]ll" "all"))) + +(transient-define-argument magit-diff:--color-moved () + :description "Color moved lines" + :class 'transient-option + :key "-m" + :argument "--color-moved=" + :reader #'magit-diff-select-color-moved-mode) + +(defun magit-diff-select-color-moved-mode (&rest _ignore) + (magit-read-char-case "Color moved " t + (?d "[d]efault" "default") + (?p "[p]lain" "plain") + (?b "[b]locks" "blocks") + (?z "[z]ebra" "zebra") + (?Z "[Z] dimmed-zebra" "dimmed-zebra"))) + +(transient-define-argument magit-diff:--color-moved-ws () + :description "Whitespace treatment for --color-moved" + :class 'transient-option + :key "=w" + :argument "--color-moved-ws=" + :reader #'magit-diff-select-color-moved-ws-mode) + +(defun magit-diff-select-color-moved-ws-mode (&rest _ignore) + (magit-read-char-case "Ignore whitespace " t + (?i "[i]ndentation" "allow-indentation-change") + (?e "[e]nd of line" "ignore-space-at-eol") + (?s "[s]pace change" "ignore-space-change") + (?a "[a]ll space" "ignore-all-space") + (?n "[n]o" "no"))) + +(transient-define-argument magit-diff:-R () + :description "Reverse sides" + :class 'transient-switch + :argument "-R" + :if 'magit-diff-argument-predicate) + +(transient-define-argument magit-diff:--no-ext-diff () + :description "Disallow external diff drivers" + :class 'transient-switch + :argument "--no-ext-diff" + :key "-x") + +(transient-define-argument magit-diff:--stat () + :description "Show stats" + :class 'transient-switch + :argument "--stat" + :key "-s" + :if 'magit-diff-argument-predicate) + +(transient-define-argument magit-diff:--show-signature () + :description "Show signature" + :class 'transient-switch + :argument "--show-signature" + :key "=g" + :if 'magit-diff-argument-predicate) + +(defun magit-diff-argument-predicate () + (or (eq (oref transient--prefix command) 'magit-diff) + (derived-mode-p 'magit-diff-mode))) + +;;;; Setup Commands + +;;;###autoload +(defun magit-diff-dwim (&optional args files) + "Show changes for the thing at point. + +For example, if point is on a commit, show the changes introduced by +that commit. Likewise if point is on the section titled \"Unstaged +changes\", then show those changes in a separate buffer. Generally +speaking, compare the thing at point with the most logical, trivial +and (in *any* situation) at least potentially useful other thing it +could be compared to. + +When the region selects commits, then compare the two commits at +either end. There are different ways two commits can be compared. +In the buffer showing the diff, you can control how the comparison, +is done, using \"D r\" and \"D f\". + +This function does not always show the changes that you might want +to view in any given situation. You can think of the changes being +shown as the smallest common denominator. There is no AI involved. +If this command never does what you want, then ignore it, and instead +use the commands that allow you to explicitly specify what you need." + (interactive (magit-diff-arguments)) + (let ((default-directory default-directory) + (section (magit-current-section))) + (cond + ((magit-section-match 'module section) + (setq default-directory + (expand-file-name + (file-name-as-directory (oref section value)))) + (magit-diff-range (oref section range))) + (t + (when (magit-section-match 'module-commit section) + (setq args nil) + (setq files nil) + (setq default-directory + (expand-file-name + (file-name-as-directory (magit-section-parent-value section))))) + (pcase (magit-diff--dwim) + ('unmerged (magit-diff-unmerged args files)) + ('unstaged (magit-diff-unstaged args files)) + ('staged + (let ((file (magit-file-at-point))) + (if (and file (equal (cddr (car (magit-file-status file))) '(?D ?U))) + ;; File was deleted by us and modified by them. Show the latter. + (magit-diff-unmerged args (list file)) + (magit-diff-staged nil args files)))) + (`(stash . ,value) (magit-stash-show value args)) + (`(commit . ,value) + (magit-diff-range (format "%s^..%s" value value) args files)) + ((and range (pred stringp)) + (magit-diff-range range args files)) + (_ (call-interactively #'magit-diff-range))))))) + +(defun magit-diff--dwim () + "Return information for performing DWIM diff. + +The information can be in three forms: +1. TYPE + A symbol describing a type of diff where no additional information + is needed to generate the diff. Currently, this includes `staged', + `unstaged' and `unmerged'. +2. (TYPE . VALUE) + Like #1 but the diff requires additional information, which is + given by VALUE. Currently, this includes `commit' and `stash', + where VALUE is the given commit or stash, respectively. +3. RANGE + A string indicating a diff range. + +If no DWIM context is found, nil is returned." + (cond + ((and-let* ((commits (magit-region-values '(commit branch) t))) + (progn + (deactivate-mark) + (concat (car (last commits)) ".." (car commits))))) + (magit-buffer-refname + (cons 'commit magit-buffer-refname)) + ((derived-mode-p 'magit-stash-mode) + (cons 'commit + (magit-section-case + (commit (oref it value)) + (file (thread-first it + (oref parent) + (oref value))) + (hunk (thread-first it + (oref parent) + (oref parent) + (oref value)))))) + ((derived-mode-p 'magit-revision-mode) + (cons 'commit magit-buffer-revision)) + ((derived-mode-p 'magit-diff-mode) + magit-buffer-range) + (t + (magit-section-case + ([* unstaged] 'unstaged) + ([* staged] 'staged) + (unmerged 'unmerged) + (unpushed (magit-diff--range-to-endpoints (oref it value))) + (unpulled (magit-diff--range-to-endpoints (oref it value))) + (branch (let ((current (magit-get-current-branch)) + (atpoint (oref it value))) + (if (equal atpoint current) + (if-let ((upstream (magit-get-upstream-branch))) + (format "%s...%s" upstream current) + (if (magit-anything-modified-p) + current + (cons 'commit current))) + (format "%s...%s" + (or current "HEAD") + atpoint)))) + (commit (cons 'commit (oref it value))) + ([file commit] (cons 'commit (oref (oref it parent) value))) + ([hunk file commit] + (cons 'commit (oref (oref (oref it parent) parent) value))) + (stash (cons 'stash (oref it value))) + (pullreq (forge--pullreq-range (oref it value) t)))))) + +(defun magit-diff--range-to-endpoints (range) + (cond ((string-match "\\.\\.\\." range) (replace-match ".." nil nil range)) + ((string-match "\\.\\." range) (replace-match "..." nil nil range)) + (t range))) + +(defun magit-diff--region-range (&optional interactive mbase) + (and-let* ((commits (magit-region-values '(commit branch) t)) + (revA (car (last commits))) + (revB (car commits))) + (progn + (when interactive + (deactivate-mark)) + (if mbase + (let ((base (magit-git-string "merge-base" revA revB))) + (cond + ((string= (magit-rev-parse revA) base) + (format "%s..%s" revA revB)) + ((string= (magit-rev-parse revB) base) + (format "%s..%s" revB revA)) + (interactive + (let ((main (magit-completing-read "View changes along" + (list revA revB) + nil t nil nil revB))) + (format "%s...%s" + (if (string= main revB) revA revB) main))) + (t "%s...%s" revA revB))) + (format "%s..%s" revA revB))))) + +(defun magit-diff-read-range-or-commit (prompt &optional secondary-default mbase) + "Read range or revision with special diff range treatment. +If MBASE is non-nil, prompt for which rev to place at the end of +a \"revA...revB\" range. Otherwise, always construct +\"revA..revB\" range." + (or (magit-diff--region-range t mbase) + (magit-read-range prompt + (or (pcase (magit-diff--dwim) + (`(commit . ,value) + (format "%s^..%s" value value)) + ((and range (pred stringp)) + range)) + secondary-default + (magit-get-current-branch))))) + +;;;###autoload +(defun magit-diff-range (rev-or-range &optional args files) + "Show differences between two commits. + +REV-OR-RANGE should be a range or a single revision. If it is a +revision, then show changes in the working tree relative to that +revision. If it is a range, but one side is omitted, then show +changes relative to `HEAD'. + +If the region is active, use the revisions on the first and last +line of the region as the two sides of the range. With a prefix +argument, instead of diffing the revisions, choose a revision to +view changes along, starting at the common ancestor of both +revisions (i.e., use a \"...\" range)." + (interactive (cons (magit-diff-read-range-or-commit "Diff for range" + nil current-prefix-arg) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev-or-range nil args files 'committed)) + +;;;###autoload +(defun magit-diff-working-tree (&optional rev args files) + "Show changes between the current working tree and the `HEAD' commit. +With a prefix argument show changes between the working tree and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff working tree and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer (or rev "HEAD") nil args files 'committed)) + +;;;###autoload +(defun magit-diff-staged (&optional rev args files) + "Show changes between the index and the `HEAD' commit. +With a prefix argument show changes between the index and +a commit read from the minibuffer." + (interactive + (cons (and current-prefix-arg + (magit-read-branch-or-commit "Diff index and commit")) + (magit-diff-arguments))) + (magit-diff-setup-buffer rev "--cached" args files 'staged)) + +;;;###autoload +(defun magit-diff-unstaged (&optional args files) + "Show changes between the working tree and the index." + (interactive (magit-diff-arguments)) + (magit-diff-setup-buffer nil nil args files 'unstaged)) + +;;;###autoload +(defun magit-diff-unmerged (&optional args files) + "Show changes that are being merged." + (interactive (magit-diff-arguments)) + (unless (magit-merge-in-progress-p) + (user-error "No merge is in progress")) + (magit-diff-setup-buffer (magit--merge-range) nil args files 'committed)) + +;;;###autoload +(defun magit-diff-while-committing () + "While committing, show the changes that are about to be committed. +While amending, invoking the command again toggles between +showing just the new changes or all the changes that will +be committed." + (interactive) + (unless (magit-commit-message-buffer) + (user-error "No commit in progress")) + (magit-commit-diff-1)) + +;;;###autoload +(defun magit-diff-buffer-file () + "Show diff for the blob or file visited in the current buffer. + +When the buffer visits a blob, then show the respective commit. +When the buffer visits a file, then show the differences between +`HEAD' and the working tree. In both cases limit the diff to +the file or blob." + (interactive) + (require 'magit) + (if-let ((file (magit-file-relative-name))) + (if magit-buffer-refname + (magit-show-commit magit-buffer-refname + (car (magit-show-commit--arguments)) + (list file)) + (save-buffer) + (let ((line (line-number-at-pos)) + (col (current-column))) + (with-current-buffer + (magit-diff-setup-buffer (or (magit-get-current-branch) "HEAD") + nil + (car (magit-diff-arguments)) + (list file) + 'unstaged + magit-diff-buffer-file-locked) + (magit-diff--goto-position file line col)))) + (user-error "Buffer isn't visiting a file"))) + +;;;###autoload +(defun magit-diff-paths (a b) + "Show changes between any two files on disk." + (interactive (list (read-file-name "First file: " nil nil t) + (read-file-name "Second file: " nil nil t))) + (magit-diff-setup-buffer nil "--no-index" nil + (list (magit-convert-filename-for-git + (expand-file-name a)) + (magit-convert-filename-for-git + (expand-file-name b))) + 'undefined)) + +(defun magit-show-commit--arguments () + (pcase-let ((`(,args ,diff-files) + (magit-diff-arguments 'magit-revision-mode))) + (list args (if (derived-mode-p 'magit-log-mode) + (and (or magit-revision-filter-files-on-follow + (not (member "--follow" magit-buffer-log-args))) + magit-buffer-log-files) + diff-files)))) + +;;;###autoload +(defun magit-show-commit (rev &optional args files module) + "Visit the revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision." + (interactive + (pcase-let* ((mcommit (magit-section-value-if 'module-commit)) + (atpoint (or mcommit + (magit-thing-at-point 'git-revision t) + (magit-branch-or-commit-at-point))) + (`(,args ,files) (magit-show-commit--arguments))) + (list (or (and (not current-prefix-arg) atpoint) + (magit-read-branch-or-commit "Show commit" atpoint)) + args + files + (and mcommit + (magit-section-parent-value (magit-current-section)))))) + (require 'magit) + (let* ((file (magit-file-relative-name)) + (line (and file (line-number-at-pos)))) + (magit-with-toplevel + (when module + (setq default-directory + (expand-file-name (file-name-as-directory module)))) + (unless (magit-commit-p rev) + (user-error "%s is not a commit" rev)) + (when file + (save-buffer)) + (let ((buf (magit-revision-setup-buffer rev args files))) + (when file + (let ((line (magit-diff-visit--offset file (list "-R" rev) line)) + (col (current-column))) + (with-current-buffer buf + (magit-diff--goto-position file line col)))))))) + +(defun magit-diff--locate-hunk (file line &optional parent) + (and-let* ((diff (cl-find-if (##and (cl-typep % 'magit-file-section) + (equal (oref % value) file)) + (oref (or parent magit-root-section) children)))) + (let ((hunks (oref diff children))) + (cl-block nil + (while-let ((hunk (pop hunks))) + (when-let ((range (oref hunk to-range))) + (pcase-let* ((`(,beg ,len) range) + (end (+ beg len))) + (cond ((> beg line) (cl-return (list diff nil))) + ((<= beg line end) (cl-return (list hunk t))) + ((null hunks) (cl-return (list hunk nil))))))))))) + +(defun magit-diff--goto-position (file line column &optional parent) + (when-let ((pos (magit-diff--locate-hunk file line parent))) + (pcase-let ((`(,section ,exact) pos)) + (cond ((cl-typep section 'magit-file-section) + (goto-char (oref section start))) + (exact + (goto-char (oref section content)) + (let ((pos (car (oref section to-range)))) + (while (or (< pos line) + (= (char-after) ?-)) + (unless (= (char-after) ?-) + (cl-incf pos)) + (forward-line))) + (forward-char (1+ column))) + (t + (goto-char (oref section start)) + (setq section (oref section parent)))) + (while section + (when (oref section hidden) + (magit-section-show section)) + (setq section (oref section parent)))) + t)) + +;;;; Setting Commands + +(defun magit-diff-switch-range-type () + "Convert diff range type. +Change \"revA..revB\" to \"revA...revB\", or vice versa." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (setq magit-buffer-range + (replace-match (if (string= (match-string 2 magit-buffer-range) "..") + "..." + "..") + t t magit-buffer-range 2)) + (user-error "No range to change")) + (magit-refresh)) + +(defun magit-diff-flip-revs () + "Swap revisions in diff range. +Change \"revA..revB\" to \"revB..revA\"." + (interactive) + (if (and magit-buffer-range + (derived-mode-p 'magit-diff-mode) + (string-match magit-range-re magit-buffer-range)) + (progn + (setq magit-buffer-range + (concat (match-string 3 magit-buffer-range) + (match-string 2 magit-buffer-range) + (match-string 1 magit-buffer-range))) + (magit-refresh)) + (user-error "No range to swap"))) + +(defun magit-diff-toggle-file-filter () + "Toggle the file restriction of the current buffer's diffs. +If the current buffer's mode is derived from `magit-log-mode', +toggle the file restriction in the repository's revision buffer +instead." + (interactive) + (cl-flet ((toggle () + (if (or magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (cl-rotatef magit-buffer-diff-files + magit-buffer-diff-files-suspended) + (setq magit-buffer-diff-files + (transient-infix-read 'magit:--))) + (magit-refresh))) + (cond + ((derived-mode-p 'magit-log-mode + 'magit-cherry-mode + 'magit-reflog-mode) + (if-let ((buffer (magit-get-mode-buffer 'magit-revision-mode))) + (with-current-buffer buffer (toggle)) + (message "No revision buffer"))) + ((local-variable-p 'magit-buffer-diff-files) + (toggle)) + (t + (user-error "Cannot toggle file filter in this buffer"))))) + +(defun magit-diff-less-context (&optional count) + "Decrease the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context (##max 0 (- (or % 0) count)))) + +(defun magit-diff-more-context (&optional count) + "Increase the context for diff hunks by COUNT lines." + (interactive "p") + (magit-diff-set-context (##+ (or % 0) count))) + +(defun magit-diff-default-context () + "Reset context for diff hunks to the default height." + (interactive) + (magit-diff-set-context #'ignore)) + +(defun magit-diff-set-context (fn) + (when (derived-mode-p 'magit-merge-preview-mode) + (user-error "Cannot use %s in %s" this-command major-mode)) + (let* ((def (if-let ((context (magit-get "diff.context"))) + (string-to-number context) + 3)) + (val magit-buffer-diff-args) + (arg (seq-find (##string-match "^-U\\([0-9]+\\)?$" %) val)) + (num (if-let ((str (and arg (match-string 1 arg)))) + (string-to-number str) + def)) + (val (delete arg val)) + (num (funcall fn num)) + (arg (and num (not (= num def)) (format "-U%d" num))) + (val (if arg (cons arg val) val))) + (setq magit-buffer-diff-args val)) + (magit-refresh)) + +(defun magit-diff-get-context () + (string-to-number + (or (seq-some (##and (string-match "\\`-U\\([0-9]+\\)?\\'" %) + (match-string 1 %)) + magit-buffer-diff-args) + (magit-get "diff.context") + "3"))) + +(defun magit-diff-context-p () + (if-let ((arg (seq-find (##string-match "^-U\\([0-9]+\\)$" %) + magit-buffer-diff-args))) + (not (equal arg "-U0")) + t)) + +(defun magit-diff-ignore-any-space-p () + (seq-some (##member % magit-buffer-diff-args) + '("--ignore-cr-at-eol" + "--ignore-space-at-eol" + "--ignore-space-change" "-b" + "--ignore-all-space" "-w" + "--ignore-blank-space"))) + +(defun magit-diff-toggle-refine-hunk (&optional style) + "Turn diff-hunk refining on or off. + +If hunk refining is currently on, then hunk refining is turned off. +If hunk refining is off, then hunk refining is turned on, in +`selected' mode (only the currently selected hunk is refined). + +With a prefix argument, the \"third choice\" is used instead: +If hunk refining is currently on, then refining is kept on, but +the refining mode (`selected' or `all') is switched. +If hunk refining is off, then hunk refining is turned on, in +`all' mode (all hunks refined). + +Customize variable `magit-diff-refine-hunk' to change the default mode." + (interactive "P") + (setq-local magit-diff-refine-hunk + (if style + (if (eq magit-diff-refine-hunk 'all) t 'all) + (not magit-diff-refine-hunk))) + (magit-diff-update-hunk-refinement)) + +;;;; Visit Commands +;;;;; Dwim Variants + +(defun magit-diff-visit-file (file &optional other-window) + "From a diff visit the appropriate version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +The location of point inside the diff determines which file is +being visited. The visited version depends on what changes the +diff is about. + +1. If the diff shows uncommitted changes (i.e., stage or unstaged + changes), then visit the file in the working tree (i.e., the + same \"real\" file that `find-file' would visit). In all + other cases visit a \"blob\" (i.e., the version of a file as + stored in some commit). + +2. If point is on a removed line, then visit the blob for the + first parent of the commit that removed that line, i.e., the + last commit where that line still exists. + +3. If point is on an added or context line, then visit the blob + that adds that line, or if the diff shows from more than a + single commit, then visit the blob from the last of these + commits. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. + +Note that this command only works if point is inside a diff. +In other cases `magit-find-file' (which see) has to be used." + (interactive (list (magit-diff--file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file nil + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-file-other-window (file) + "From a diff visit the appropriate version of FILE in another window. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-diff--file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-file-other-frame (file) + "From a diff visit the appropriate version of FILE in another frame. +Like `magit-diff-visit-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-diff--file-at-point t t))) + (magit-diff-visit-file--internal file nil #'switch-to-buffer-other-frame)) + +;;;;; Worktree Variants + +(defun magit-diff-visit-worktree-file (file &optional other-window) + "From a diff visit the worktree version of FILE. + +Display the buffer in the selected window. With a prefix +argument OTHER-WINDOW display the buffer in another window +instead. + +Visit the worktree version of the appropriate file. The location +of point inside the diff determines which file is being visited. + +Unlike `magit-diff-visit-file' always visits the \"real\" file in +the working tree, i.e the \"current version\" of the file. + +In the file-visiting buffer also go to the line that corresponds +to the line that point is on in the diff. Lines that were added +or removed in the working tree, the index and other commits in +between are automatically accounted for." + (interactive (list (magit-file-at-point t t) current-prefix-arg)) + (magit-diff-visit-file--internal file t + (if other-window + #'switch-to-buffer-other-window + #'pop-to-buffer-same-window))) + +(defun magit-diff-visit-worktree-file-other-window (file) + "From a diff visit the worktree version of FILE in another window. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-window'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-window)) + +(defun magit-diff-visit-worktree-file-other-frame (file) + "From a diff visit the worktree version of FILE in another frame. +Like `magit-diff-visit-worktree-file' but use +`switch-to-buffer-other-frame'." + (interactive (list (magit-file-at-point t t))) + (magit-diff-visit-file--internal file t #'switch-to-buffer-other-frame)) + +;;;;; Internal + +(defun magit-diff-visit-file--internal (file force-worktree fn) + "From a diff visit the appropriate version of FILE. +If FORCE-WORKTREE is non-nil, then visit the worktree version of +the file, even if the diff is about a committed change. Use FN +to display the buffer in some window." + (if (file-accessible-directory-p file) + (magit-diff-visit-directory file force-worktree) + (pcase-let ((`(,buf ,pos) + (magit-diff-visit-file--noselect file force-worktree))) + (funcall fn buf) + (magit-diff-visit-file--setup buf pos) + buf))) + +(defun magit-diff-visit-directory (directory &optional other-window) + "Visit DIRECTORY in some window. +Display the buffer in the selected window unless OTHER-WINDOW is +non-nil. If DIRECTORY is the top-level directory of the current +repository, then visit the containing directory using Dired and +in the Dired buffer put point on DIRECTORY. Otherwise display +the Magit-Status buffer for DIRECTORY." + (if (equal (magit-toplevel directory) + (magit-toplevel)) + (dired-jump other-window (concat directory "/.")) + (let ((display-buffer-overriding-action + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window)))) + (magit-status-setup-buffer directory)))) + +(defun magit-diff-visit-file--setup (buf pos) + (if-let ((win (get-buffer-window buf 'visible))) + (with-selected-window win + (when pos + (unless (<= (point-min) pos (point-max)) + (widen)) + (goto-char pos)) + (when (and buffer-file-name + (magit-anything-unmerged-p buffer-file-name)) + (smerge-start-session)) + (run-hooks 'magit-diff-visit-file-hook)) + (error "File buffer is not visible"))) + +(defun magit-diff-visit-file--noselect (&optional file goto-worktree) + (unless file + (setq file (magit-diff--file-at-point t t))) + (let* ((hunk (magit-diff-visit--hunk)) + (goto-from (and hunk + (magit-diff-visit--goto-from-p hunk goto-worktree))) + (line (and hunk (magit-diff-hunk-line hunk goto-from))) + (col (and hunk (magit-diff-hunk-column hunk goto-from))) + (spec (magit-diff--dwim)) + (rev (if goto-from + (magit-diff-visit--range-from spec) + (magit-diff-visit--range-to spec))) + (buf (if (or goto-worktree + (equal magit-buffer-typearg "--no-index") + (and (not (stringp rev)) + (or magit-diff-visit-avoid-head-blob + (not goto-from)))) + (or (get-file-buffer file) + (find-file-noselect file)) + (magit-find-file-noselect (if (stringp rev) rev "HEAD") + file)))) + (if line + (with-current-buffer buf + (cond ((eq rev 'staged) + (setq line (magit-diff-visit--offset file nil line))) + ((and goto-worktree + (stringp rev)) + (setq line (magit-diff-visit--offset file rev line)))) + (list buf (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column col) + (point)))) + (list buf nil)))) + +(defun magit-diff--file-at-point (&optional expand assert) + ;; This is a variation of magit-file-at-point. + (if-let* ((file-section (magit-section-case + (file it) + (hunk (oref it parent)))) + (file (or (and (magit-section-match 'hunk) + (magit-diff-visit--goto-from-p + (magit-current-section) nil) + (oref file-section source)) + (oref file-section value)))) + (cond ((equal magit-buffer-typearg "--no-index") + (concat "/" file)) + (expand (expand-file-name file (magit-toplevel))) + (file)) + (when assert + (user-error "No file at point")))) + +(defun magit-diff-visit--hunk () + (and-let* ((scope (magit-diff-scope)) + (section (magit-current-section))) + (progn + (cl-case scope + ((file files) + (setq section (car (oref section children)))) + (list + (setq section (car (oref section children))) + (when section + (setq section (car (oref section children)))))) + (and + ;; Unmerged files appear in the list of staged changes + ;; but unlike in the list of unstaged changes no diffs + ;; are shown here. In that case `section' is nil. + section + ;; Currently the `hunk' type is also abused for file + ;; mode changes, which we are not interested in here. + (not (equal (oref section value) '(chmod))) + section)))) + +(defun magit-diff-visit--goto-from-p (section in-worktree) + (and magit-diff-visit-previous-blob + (not in-worktree) + (not (oref section combined)) + (not (< (magit-point) (oref section content))) + (= (char-after (line-beginning-position)) ?-))) + +(defvar magit-diff-visit-jump-to-change t) + +(defun magit-diff-hunk-line (section goto-from) + (save-excursion + (goto-char (line-beginning-position)) + (with-slots (content combined from-ranges from-range to-range) section + (when (or from-range to-range) + (when (and magit-diff-visit-jump-to-change (< (point) content)) + (goto-char content) + (re-search-forward "^[-+]")) + (+ (car (if goto-from from-range to-range)) + (let ((prefix (if combined (length from-ranges) 1)) + (target (point)) + (offset 0)) + (goto-char content) + (while (< (point) target) + (unless (string-search + (if goto-from "+" "-") + (buffer-substring (point) (+ (point) prefix))) + (cl-incf offset)) + (forward-line)) + offset)))))) + +(defun magit-diff-hunk-column (section goto-from) + (if (or (< (magit-point) + (oref section content)) + (and (not goto-from) + (= (char-after (line-beginning-position)) ?-))) + 0 + (max 0 (- (+ (current-column) 2) + (length (oref section value)))))) + +(defun magit-diff-visit--range-from (spec) + (cond ((consp spec) + (concat (cdr spec) "^")) + ((stringp spec) + (car (magit-split-range spec))) + (t + spec))) + +(defun magit-diff-visit--range-to (spec) + (if (symbolp spec) + spec + (let ((rev (if (consp spec) + (cdr spec) + (cdr (magit-split-range spec))))) + (if (and magit-diff-visit-avoid-head-blob + (magit-rev-head-p rev)) + 'unstaged + rev)))) + +(defun magit-diff-visit--offset (file rev line) + (let ((offset 0)) + (with-temp-buffer + (save-excursion + (magit-with-toplevel + (magit-git-insert "diff" rev "--" file))) + (catch 'found + (while (re-search-forward + "^@@ -\\([0-9]+\\),\\([0-9]+\\) \\+\\([0-9]+\\),\\([0-9]+\\) @@.*\n" + nil t) + (let ((from-beg (string-to-number (match-string 1))) + (from-len (string-to-number (match-string 2))) + ( to-len (string-to-number (match-string 4)))) + (if (<= from-beg line) + (if (< (+ from-beg from-len) line) + (cl-incf offset (- to-len from-len)) + (let ((rest (- line from-beg))) + (while (> rest 0) + (pcase (char-after) + (?\s (cl-decf rest)) + (?- (cl-decf offset) (cl-decf rest)) + (?+ (cl-incf offset))) + (forward-line)))) + (throw 'found nil)))))) + (+ line offset))) + +;;;;; Movement + +(defun magit-jump-to-diffstat-or-diff () + "Jump to the diffstat or diff. +When point is on a file inside the diffstat section, then jump +to the respective diff section, otherwise jump to the diffstat +section or a child thereof." + (interactive) + (if-let ((section (magit-get-section + (append (magit-section-case + ([file diffstat] `((file . ,(oref it value)))) + (file `((file . ,(oref it value)) (diffstat))) + (t '((diffstat)))) + (magit-section-ident magit-root-section))))) + (magit-section-goto section) + (user-error "No diffstat in this buffer"))) + +;;;; Scroll Commands + +(defun magit-diff-show-or-scroll-up () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer up. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll #'scroll-up)) + +(defun magit-diff-show-or-scroll-down () + "Update the commit or diff buffer for the thing at point. + +Either show the commit or stash at point in the appropriate +buffer, or if that buffer is already being displayed in the +current frame and contains information about that commit or +stash, then instead scroll the buffer down. If there is no +commit or stash at point, then prompt for a commit." + (interactive) + (magit-diff-show-or-scroll #'scroll-down)) + +(defun magit-diff-show-or-scroll (fn) + (let (rev cmd buf win) + (cond + ((and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk)) + (setq rev (oref (magit-current-blame-chunk) orig-rev)) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + ((derived-mode-p 'git-rebase-mode) + (with-slots (action-type target) + (git-rebase-current-line) + (if (not (eq action-type 'commit)) + (user-error "No commit on this line") + (setq rev target) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))))) + (t + (magit-section-case + (branch + (setq rev (magit-ref-maybe-qualify (oref it value))) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (commit + (setq rev (oref it value)) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (tag + (setq rev (magit-rev-hash (oref it value))) + (setq cmd #'magit-show-commit) + (setq buf (magit-get-mode-buffer 'magit-revision-mode))) + (stash + (setq rev (oref it value)) + (setq cmd #'magit-stash-show) + (setq buf (magit-get-mode-buffer 'magit-stash-mode)))))) + (if rev + (if (and buf + (setq win (get-buffer-window buf)) + (with-current-buffer buf + (and (equal rev magit-buffer-revision) + (equal (magit-rev-parse rev) + magit-buffer-revision-hash)))) + (with-selected-window win + (condition-case nil + (funcall fn) + (error + (goto-char (pcase fn + ('scroll-up (point-min)) + ('scroll-down (point-max))))))) + (let ((magit-display-buffer-noselect t)) + (if (eq cmd #'magit-show-commit) + (apply #'magit-show-commit rev (magit-show-commit--arguments)) + (funcall cmd rev)))) + (call-interactively #'magit-show-commit)))) + +;;;; Section Commands + +(defun magit-section-cycle-diffs () + "Cycle visibility of diff-related sections in the current buffer." + (interactive) + (when-let ((sections + (cond ((derived-mode-p 'magit-status-mode) + (mapcan (lambda (section) + (and section + (progn + (when (oref section hidden) + (magit-section-show section)) + (oref section children)))) + (list (magit-get-section '((staged) (status))) + (magit-get-section '((unstaged) (status)))))) + ((derived-mode-p 'magit-diff-mode) + (seq-filter #'magit-file-section-p + (oref magit-root-section children)))))) + (if (seq-some (##oref % hidden) sections) + (dolist (s sections) + (magit-section-show s) + (magit-section-hide-children s)) + (let ((children (mapcan (##copy-sequence (oref % children)) sections))) + (cond ((and (seq-some (##oref % hidden) children) + (seq-some (##oref % children) children)) + (mapc #'magit-section-show-headings sections)) + ((seq-some #'magit-section-hidden-body children) + (mapc #'magit-section-show-children sections)) + (t + (mapc #'magit-section-hide sections))))))) + +;;; Diff Mode + +(defvar-keymap magit-diff-mode-map + :doc "Keymap for `magit-diff-mode'." + :parent magit-mode-map + "C-c C-d" #'magit-diff-while-committing + "C-c C-b" #'magit-go-backward + "C-c C-f" #'magit-go-forward + "SPC" #'scroll-up + "DEL" #'scroll-down + "j" #'magit-jump-to-diffstat-or-diff + " " #'magit-patch-save) + +(define-derived-mode magit-diff-mode magit-mode "Magit Diff" + "Mode for looking at a Git diff. + +This mode is documented in info node `(magit)Diff Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-diff-mode-map}" + :interactive nil + :group 'magit-diff + (magit-hack-dir-local-variables) + (setq magit--imenu-item-types 'file)) + +(put 'magit-diff-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-diff-setup-buffer ( range typearg args files + &optional type locked) + (require 'magit) + (magit-setup-buffer #'magit-diff-mode locked + (magit-buffer-range range) + (magit-buffer-typearg typearg) + (magit-buffer-diff-type type) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files) + (magit-buffer-diff-files-suspended nil))) + +(defun magit-diff-refresh-buffer () + "Refresh the current `magit-diff-mode' buffer." + (magit-set-header-line-format + (if (equal magit-buffer-typearg "--no-index") + (apply #'format "Differences between %s and %s" magit-buffer-diff-files) + (concat (if magit-buffer-range + (if (string-match-p "\\(\\.\\.\\|\\^-\\)" + magit-buffer-range) + (format "Changes in %s" magit-buffer-range) + (let ((msg "Changes from %s to %s") + (end (if (equal magit-buffer-typearg "--cached") + "index" + "working tree"))) + (if (member "-R" magit-buffer-diff-args) + (format msg end magit-buffer-range) + (format msg magit-buffer-range end)))) + (cond ((equal magit-buffer-typearg "--cached") + "Staged changes") + ((and (magit-repository-local-get 'this-commit-command) + (not (magit-anything-staged-p))) + "Uncommitting changes") + (t "Unstaged changes"))) + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " in file " (car magit-buffer-diff-files))) + (_ (concat " in files " + (string-join magit-buffer-diff-files ", "))))))) + (setq magit-buffer-range-hashed + (and magit-buffer-range (magit-hash-range magit-buffer-range))) + (magit-insert-section (diffbuf) + (magit-run-section-hook 'magit-diff-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-diff-mode)) + (nconc (cond (magit-buffer-range + (delq nil (list magit-buffer-range magit-buffer-typearg))) + ((equal magit-buffer-typearg "--cached") + (list 'staged)) + (t + (list 'unstaged magit-buffer-typearg))) + (and magit-buffer-diff-files (cons "--" magit-buffer-diff-files)))) + +(cl-defmethod magit-menu-common-value ((_section magit-diff-section)) + (magit-diff-scope)) + +(defvar-keymap magit-diff-section-map + :doc "Keymap for diff sections. +The classes `magit-file-section' and `magit-hunk-section' derive +from the abstract `magit-diff-section' class. Accordingly this +keymap is the parent of their keymaps." + "C-j" #'magit-diff-visit-worktree-file + "C-" #'magit-diff-visit-worktree-file + "C-x 4 " #'magit-diff-visit-file-other-window + "C-x 5 " #'magit-diff-visit-file-other-frame + "&" #'magit-do-async-shell-command + "C" #'magit-commit-add-log + "C-x a" #'magit-add-change-log-entry + "C-x 4 a" #'magit-add-change-log-entry-other-window + "C-c C-t" #'magit-diff-trace-definition + "C-c C-e" #'magit-diff-edit-hunk-commit + " " #'magit-file-rename + " " #'magit-file-untrack + " " #'magit-diff-visit-file + " " #'magit-reverse + " " #'magit-discard + " " #'magit-unstage + " " #'magit-stage + " " #'magit-apply + "<8>" (magit-menu-item "Rename file" #'magit-file-rename + '(:enable (eq (magit-diff-scope) 'file))) + "<7>" (magit-menu-item "Untrack %x" #'magit-file-untrack) + "<6>" (magit-menu-item "Visit file" #'magit-diff-visit-file + '(:enable (memq (magit-diff-scope) '(file files)))) + "<5>" (magit-menu-item "Reverse %x" #'magit-reverse + '(:enable (not (memq (magit-diff-type) + '(untracked unstaged))))) + "<4>" (magit-menu-item "Discard %x" #'magit-discard + '(:enable (not (memq (magit-diff-type) + '(committed undefined))))) + "<3>" (magit-menu-item "Unstage %x" #'magit-unstage + '(:enable (eq (magit-diff-type) 'staged))) + "<2>" (magit-menu-item "Stage %x" #'magit-stage + '(:enable (eq (magit-diff-type) 'unstaged))) + "<1>" (magit-menu-item "Apply %x" #'magit-apply + '(:enable (not (memq (magit-diff-type) + '(unstaged staged)))))) + +(defvar-keymap magit-file-section-map + ;; Even though this derived map doesn't add any bindings by default, + ;; it is quite possible that some users would want to add their own. + :doc "Keymap for `file' sections." + :parent magit-diff-section-base-map) + +(defvar-keymap magit-hunk-section-smerge-map + :doc "Keymap bound to `smerge-command-prefix' in `magit-hunk-section-map'." + "RET" #'magit-smerge-keep-current + "a" #'magit-smerge-keep-all + "u" #'magit-smerge-keep-upper + "b" #'magit-smerge-keep-base + "l" #'magit-smerge-keep-lower) + +(defvar magit-hunk-section-map + (let ((map (make-sparse-keymap)) + (key (key-description smerge-command-prefix))) + (when (key-valid-p key) + (keymap-set map key magit-hunk-section-smerge-map)) + (set-keymap-parent map magit-diff-section-base-map) + map) + "Keymap for `hunk' sections.") + +(defconst magit-diff-conflict-headline-re + (concat "^" (regexp-opt + ;; Defined in merge-tree.c in this order. + '("merged" + "added in remote" + "added in both" + "added in local" + "removed in both" + "changed in both" + "removed in local" + "removed in remote")))) + +(defconst magit-diff-headline-re + (concat "^\\(@@@?\\|diff\\|Submodule\\|" + "\\* Unmerged path\\|" + (substring magit-diff-conflict-headline-re 1) + "\\)")) + +(defconst magit-diff-statline-re + (concat "^ ?" + "\\(.*\\)" ; file + "\\( +| +\\)" ; separator + "\\([0-9]+\\|Bin\\(?: +[0-9]+ -> [0-9]+ bytes\\)?$\\) ?" + "\\(\\+*\\)" ; add + "\\(-*\\)$")) ; del + +(defvar magit-diff--reset-non-color-moved + (list + "-c" "color.diff.context=normal" + "-c" "color.diff.plain=normal" ; historical synonym for context + "-c" "color.diff.meta=normal" + "-c" "color.diff.frag=normal" + "-c" "color.diff.func=normal" + "-c" "color.diff.old=normal" + "-c" "color.diff.new=normal" + "-c" "color.diff.commit=normal" + "-c" "color.diff.whitespace=normal" + ;; "git-range-diff" does not support "--color-moved", so we don't + ;; need to reset contextDimmed, oldDimmed, newDimmed, contextBold, + ;; oldBold, and newBold. + )) + +(defun magit-insert-diff () + "Insert the diff into this `magit-diff-mode' buffer." + (magit--insert-diff t + "diff" magit-buffer-range "-p" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-typearg + magit-buffer-diff-args "--" + magit-buffer-diff-files)) + +(defun magit--insert-diff (keep-error &rest args) + (declare (indent 1)) + (pcase-let ((`(,cmd . ,args) + (flatten-tree args)) + (magit-git-global-arguments + (remove "--literal-pathspecs" magit-git-global-arguments))) + ;; We need to generate diffs with --ita-visible-in-index so that + ;; `magit-stage' can work with intent-to-add files (see #4026). + (unless (equal cmd "merge-tree") + (push "--ita-visible-in-index" args)) + (setq args (magit-diff--maybe-add-stat-arguments args)) + (when (cl-member-if (##string-prefix-p "--color-moved" %) args) + (push "--color=always" args) + (setq magit-git-global-arguments + (append magit-diff--reset-non-color-moved + magit-git-global-arguments))) + (magit--git-wash #'magit-diff-wash-diffs + (if (member "--no-index" args) + 'wash-anyway + (or keep-error t)) + cmd args))) + +(defun magit-diff--maybe-add-stat-arguments (args) + (if (member "--stat" args) + (append (if (functionp magit-diff-extra-stat-arguments) + (funcall magit-diff-extra-stat-arguments) + magit-diff-extra-stat-arguments) + args) + args)) + +(defun magit-diff-use-window-width-as-stat-width () + "Use the `window-width' as the value of `--stat-width'." + (and-let* ((window (get-buffer-window (current-buffer) 'visible))) + (list (format "--stat-width=%d" (window-width window))))) + +(defun magit-diff-wash-diffs (args &optional limit) + (run-hooks 'magit-diff-wash-diffs-hook) + (when (member "--show-signature" args) + (magit-diff-wash-signature magit-buffer-revision-hash)) + (when (member "--stat" args) + (magit-diff-wash-diffstat)) + (when (re-search-forward magit-diff-headline-re limit t) + (goto-char (line-beginning-position)) + (magit-wash-sequence (##magit-diff-wash-diff args)) + (insert ?\n))) + +(defun magit-diff-wash-signature (object) + (cond + ((looking-at "^No signature") + (delete-line)) + ((looking-at "^gpg: ") + (let (title end) + (save-excursion + (while (looking-at "^gpg: ") + (cond + ((looking-at "^gpg: Good signature from") + (setq title (propertize + (buffer-substring (point) (line-end-position)) + 'face 'magit-signature-good))) + ((looking-at "^gpg: Can't check signature") + (setq title (propertize + (buffer-substring (point) (line-end-position)) + 'face '(italic bold))))) + (forward-line)) + (setq end (point-marker))) + (magit-insert-section (signature object title) + (when title + (magit-insert-heading title)) + (goto-char end) + (set-marker end nil) + (insert "\n")))))) + +(defun magit-diff-wash-diffstat () + (let (heading (beg (point))) + (when (re-search-forward "^ ?\\([0-9]+ +files? change[^\n]*\n\\)" nil t) + (setq heading (match-string 1)) + (magit-delete-match) + (goto-char beg) + (magit-insert-section (diffstat) + (magit-insert-heading + (propertize heading 'font-lock-face 'magit-diff-file-heading)) + (let (files) + (while (looking-at "^[-0-9]+\t[-0-9]+\t\\(.+\\)$") + (push (magit-decode-git-path + (let ((f (match-string 1))) + (cond + ((string-match "{.* => \\(.*\\)}" f) + (replace-match (match-string 1 f) nil t f)) + ((string-match " => " f) + (substring f (match-end 0))) + (t f)))) + files) + (magit-delete-line)) + (setq files (nreverse files)) + (while (looking-at magit-diff-statline-re) + (magit-bind-match-strings (file sep cnt add del) nil + (magit-delete-line) + (when (string-match " +$" file) + (setq sep (concat (match-string 0 file) sep)) + (setq file (substring file 0 (match-beginning 0)))) + (let ((le (length file)) ld) + (setq file (magit-decode-git-path file)) + (setq ld (length file)) + (when (> le ld) + (setq sep (concat (make-string (- le ld) ?\s) sep)))) + (magit-insert-section (file (pop files)) + (insert (magit-format-file 'stat file 'magit-filename)) + (insert sep cnt " ") + (when add + (insert (propertize add 'font-lock-face + 'magit-diffstat-added))) + (when del + (insert (propertize del 'font-lock-face + 'magit-diffstat-removed))) + (insert "\n"))))) + (if (looking-at "^$") (forward-line) (insert "\n")))))) + +(defun magit-diff-wash-diff (args) + (when (cl-member-if (##string-prefix-p "--color-moved" %) args) + (require 'ansi-color) + (ansi-color-apply-on-region (point-min) (point-max))) + (cond + ((looking-at "^Submodule") + (magit-diff-wash-submodule)) + ((looking-at "^\\* Unmerged path \\(.*\\)") + (let ((file (magit-decode-git-path (match-string 1)))) + (magit-delete-line) + (unless (and (derived-mode-p 'magit-status-mode) + (not (member "--cached" args))) + (magit-insert-section (file file) + (insert (propertize + (format "unmerged %s%s" file + (pcase (cddr (car (magit-file-status file))) + ('(?D ?D) " (both deleted)") + ('(?D ?U) " (deleted by us)") + ('(?U ?D) " (deleted by them)") + ('(?A ?A) " (both added)") + ('(?A ?U) " (added by us)") + ('(?U ?A) " (added by them)") + ('(?U ?U) ""))) + 'font-lock-face 'magit-diff-file-heading)) + (insert ?\n)))) + t) + ((looking-at magit-diff-conflict-headline-re) + (let ((long-status (match-string 0)) + (status "BUG") + file orig base) + (if (equal long-status "merged") + (progn (setq status long-status) + (setq long-status nil)) + (setq status (pcase-exhaustive long-status + ("added in remote" "new file") + ("added in both" "new file") + ("added in local" "new file") + ("removed in both" "removed") + ("changed in both" "changed") + ("removed in local" "removed") + ("removed in remote" "removed")))) + (magit-delete-line) + (while (looking-at + "^ \\([^ ]+\\) +[0-9]\\{6\\} \\([a-z0-9]\\{40,\\}\\) \\(.+\\)$") + (magit-bind-match-strings (side _blob name) nil + (pcase side + ("result" (setq file name)) + ("our" (setq orig name)) + ("their" (setq file name)) + ("base" (setq base name)))) + (magit-delete-line)) + (when orig (setq orig (magit-decode-git-path orig))) + (when file (setq file (magit-decode-git-path file))) + (magit-diff-insert-file-section + (or file base) orig status nil nil nil nil long-status))) + ;; The files on this line may be ambiguous due to whitespace. + ;; That's okay. We can get their names from subsequent headers. + ((looking-at "^diff --\ +\\(?:\\(?1:git\\) \\(?:\\(?2:.+?\\) \\2\\)?\ +\\|\\(?:cc\\|combined\\) \\(?3:.+\\)\\)") + (let ((status (cond ((equal (match-string 1) "git") "modified") + ((derived-mode-p 'magit-revision-mode) "resolved") + (t "unmerged"))) + (orig nil) + (file (or (match-string 2) (match-string 3))) + (header (list (buffer-substring-no-properties + (line-beginning-position) (1+ (line-end-position))))) + (modes nil) + (rename nil) + (binary nil)) + (magit-delete-line) + (while (not (or (eobp) (looking-at magit-diff-headline-re))) + (cond + ((looking-at "old mode \\(?:[^\n]+\\)\nnew mode \\(?:[^\n]+\\)\n") + (setq modes (match-string 0))) + ((looking-at "deleted file .+\n") + (setq status "deleted")) + ((looking-at "new file .+\n") + (setq status "new file")) + ((looking-at "rename from \\(.+\\)\nrename to \\(.+\\)\n") + (setq rename (match-string 0)) + (setq orig (match-string 1)) + (setq file (match-string 2)) + (setq status "renamed")) + ((looking-at "copy from \\(.+\\)\ncopy to \\(.+\\)\n") + (setq orig (match-string 1)) + (setq file (match-string 2)) + (setq status "new file")) + ((looking-at "similarity index .+\n")) + ((looking-at "dissimilarity index .+\n")) + ((looking-at "index .+\n")) + ((looking-at "--- \\(.+?\\)\t?\n") + (unless (equal (match-string 1) "/dev/null") + (setq orig (match-string 1)))) + ((looking-at "\\+\\+\\+ \\(.+?\\)\t?\n") + (unless (equal (match-string 1) "/dev/null") + (setq file (match-string 1)))) + ((looking-at "Binary files .+ and .+ differ\n") + (setq binary t)) + ((looking-at "Binary files differ\n") + (setq binary t)) + ;; TODO Use all combined diff extended headers. + ((looking-at "mode .+\n")) + ((error "BUG: Unknown extended header: %S" + (buffer-substring (point) (line-end-position))))) + ;; These headers are treated as some sort of special hunk. + (unless (or (string-prefix-p "old mode" (match-string 0)) + (string-prefix-p "rename" (match-string 0))) + (push (match-string 0) header)) + (magit-delete-match)) + (when orig + (setq orig (magit-decode-git-path orig))) + (setq file (magit-decode-git-path file)) + (setq header (nreverse header)) + ;; KLUDGE `git-log' ignores `--no-prefix' when `-L' is used. + (when (and (derived-mode-p 'magit-log-mode) + (seq-some (##string-prefix-p "-L" %) + magit-buffer-log-args)) + (when orig + (setq orig (substring orig 2))) + (setq file (substring file 2)) + (setq header (list (save-excursion + (string-match "diff [^ ]+" (car header)) + (format "%s %s %s\n" + (match-string 0 (car header)) + (or orig file) + (or file orig))) + (format "--- %s\n" (or orig "/dev/null")) + (format "+++ %s\n" (or file "/dev/null"))))) + (setq header (string-join header)) + (magit-diff-insert-file-section + file orig status modes rename header binary nil))))) + +(defun magit-diff-insert-file-section + (file orig status modes rename header binary long-status) + (magit-insert-section + ( file file + (or (equal status "deleted") (derived-mode-p 'magit-status-mode)) + :source (and (not (equal orig file)) orig) + :header header + :binary binary) + (magit-insert-heading + (magit-format-file 'diff file 'magit-diff-file-heading status + (and (not (equal orig file)) orig)) + (cond ((and binary long-status) + (format " (%s, binary)" long-status)) + ((or binary long-status) + (format " (%s)" (if binary "binary" long-status))))) + (when modes + (magit-insert-section (hunk '(chmod)) + (magit-insert-heading (propertize modes 'face 'default)))) + (when rename + (magit-insert-section (hunk '(rename)) + (magit-insert-heading (propertize rename 'face 'default)))) + (magit-wash-sequence #'magit-diff-wash-hunk))) + +(defun magit-format-file (kind file face &optional status orig) + (funcall magit-format-file-function kind file face status orig)) + +(defun magit-format-file-default (_kind file face &optional status orig) + "Show only the Git status and the filename." + (propertize (concat (and status (format "%-11s" status)) + (if orig (format "%s -> %s" orig file) file)) + 'font-lock-face face)) + +(defun magit-format-file-all-the-icons (kind file face &optional status orig) + "Show the status, filename and icon (using the `all-the-icons' package). +You have to explicitly install the `all-the-icons' package, else this +function errors." + (cl-flet ((icon (if (or (eq kind 'module) (string-suffix-p "/" file)) + 'all-the-icons-icon-for-dir + 'all-the-icons-icon-for-file))) + (cl-letf (((symbol-function 'all-the-icons-dir-is-submodule) + (if (eq kind 'module) + (lambda (_) t) + (symbol-function 'all-the-icons-dir-is-submodule)))) + (propertize (concat (and status (format "%-11s" status)) + (if orig + (format "%s %s -> %s %s" + (icon orig) orig + (icon file) file) + (format "%s %s" (icon file) file))) + 'font-lock-face face)))) + +(defun magit-format-file-nerd-icons (kind file face &optional status orig) + "Show the status, filename and icon (using the `nerd-icons' package). +You have to explicitly install the `nerd-icons' package, else this +function errors." + (cl-flet ((icon (if (or (eq kind 'module) (string-suffix-p "/" file)) + 'nerd-icons-icon-for-dir + 'nerd-icons-icon-for-file))) + (cl-letf (((symbol-function 'nerd-icons-dir-is-submodule) + (if (eq kind 'module) + (lambda (_) t) + (symbol-function 'nerd-icons-dir-is-submodule)))) + (propertize (concat (and status (format "%-11s" status)) + (if orig + (format "%s %s -> %s %s" + (icon orig) orig + (icon file) file) + (format "%s %s" (icon file) file))) + 'font-lock-face face)))) + +(defun magit-diff-wash-submodule () + ;; See `show_submodule_summary' in submodule.c and "this" commit. + (when (looking-at "^Submodule \\([^ ]+\\)") + (let ((module (match-string 1)) + untracked modified) + (when (looking-at "^Submodule [^ ]+ contains untracked content$") + (magit-delete-line) + (setq untracked t)) + (when (looking-at "^Submodule [^ ]+ contains modified content$") + (magit-delete-line) + (setq modified t)) + (cond + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ :]+\\)\\( (rewind)\\)?:$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module range rewind) nil + (magit-delete-line) + (while (looking-at "^ \\([<>]\\) \\(.*\\)$") + (magit-delete-line)) + (when rewind + (setq range (replace-regexp-in-string "[^.]\\(\\.\\.\\)[^.]" + "..." range t t 1))) + (magit-insert-section (module module t) + (magit-insert-heading + (magit-format-file 'module module 'magit-diff-file-heading + "modified") + " (" + (cond (rewind "rewind") + ((string-search "..." range) "non-ff") + (t "new commits")) + (and (or modified untracked) + (concat ", " + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content")) + ")") + (magit-insert-section-body + (let ((default-directory + (file-name-as-directory + (expand-file-name module (magit-toplevel))))) + (magit-git-wash (apply-partially #'magit-log-wash-log 'module) + "log" "--oneline" "--left-right" range) + (delete-char -1)))))) + ((and (looking-at "^Submodule \\([^ ]+\\) \\([^ ]+\\) (\\([^)]+\\))$") + (equal (match-string 1) module)) + (magit-bind-match-strings (_module _range msg) nil + (magit-delete-line) + (magit-insert-section (module module) + (magit-insert-heading + (magit-format-file 'module module 'magit-diff-file-heading + "submodule") + " (" msg ")")))) + (t + (magit-insert-section (module module) + (magit-insert-heading + (magit-format-file 'module module 'magit-diff-file-heading + "modified") + " (" + (and modified "modified") + (and modified untracked " and ") + (and untracked "untracked") + " content)"))))))) + +(defun magit-diff-wash-hunk () + (when (looking-at "^@\\{2,\\} \\(.+?\\) @\\{2,\\}\\(?: \\(.*\\)\\)?") + (let* ((heading (match-string 0)) + (ranges (mapcar + (lambda (str) + (let ((range + (mapcar #'string-to-number + (split-string (substring str 1) ",")))) + ;; A single line is +1 rather than +1,1. + (if (length= range 1) + (nconc range (list 1)) + range))) + (split-string (match-string 1)))) + (about (match-string 2)) + (combined (length= ranges 3)) + (value (cons about ranges))) + (magit-delete-line) + (magit-insert-section + ( hunk value nil + :combined combined + :from-range (if combined (butlast ranges) (car ranges)) + :to-range (car (last ranges)) + :about about) + (magit-insert-heading + (propertize (concat heading "\n") + 'font-lock-face 'magit-diff-hunk-heading)) + (while (not (or (eobp) (looking-at "^[^-+\s\\]"))) + (forward-line)))) + t)) + +(defun magit-diff-expansion-threshold (section) + "Keep new diff sections collapsed if washing takes too long." + (and (magit-file-section-p section) + (> (float-time (time-since magit--refresh-start-time)) + magit-diff-expansion-threshold) + 'hide)) + +(add-hook 'magit-section-set-visibility-hook #'magit-diff-expansion-threshold) + +;;; Revision Mode + +(define-derived-mode magit-revision-mode magit-diff-mode "Magit Rev" + "Mode for looking at a Git commit. + +This mode is documented in info node `(magit)Revision Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the hunk or file at point. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\{magit-revision-mode-map}" + :interactive nil + :group 'magit-revision + (magit-hack-dir-local-variables)) + +(put 'magit-revision-mode 'magit-diff-default-arguments + '("--stat" "--no-ext-diff")) + +(defun magit-revision-setup-buffer (rev args files) + (magit-setup-buffer #'magit-revision-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)) + (magit-buffer-diff-type 'committed) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files) + (magit-buffer-diff-files-suspended nil))) + +(defun magit-revision-refresh-buffer () + (setq magit-buffer-revision-hash (magit-rev-hash magit-buffer-revision)) + (magit-set-header-line-format + (concat (magit-object-type magit-buffer-revision-hash) + " " magit-buffer-revision + (pcase (length magit-buffer-diff-files) + (0) + (1 (concat " limited to file " (car magit-buffer-diff-files))) + (_ (concat " limited to files " + (string-join magit-buffer-diff-files ", ")))))) + (magit-insert-section (commitbuf) + (magit-run-section-hook 'magit-revision-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-revision-mode)) + (cons magit-buffer-revision magit-buffer-diff-files)) + +(defun magit-insert-revision-diff () + "Insert the diff into this `magit-revision-mode' buffer." + (magit--insert-diff t + "show" "-p" "--format=" "--no-prefix" + (and (member "--stat" magit-buffer-diff-args) "--numstat") + magit-buffer-diff-args + (magit--rev-dereference magit-buffer-revision) + "--" magit-buffer-diff-files)) + +(defun magit-insert-revision-tag () + "Insert tag message and headers into a revision buffer. +This function only inserts anything when `magit-show-commit' is +called with a tag as argument, when that is called with a commit +or a ref which is not a branch, then it inserts nothing." + (when (equal (magit-object-type magit-buffer-revision) "tag") + (magit-insert-section (taginfo) + (let ((beg (point))) + ;; "git verify-tag -v" would output what we need, but the gpg + ;; output is send to stderr and we have no control over the + ;; order in which stdout and stderr are inserted, which would + ;; make parsing hard. We are forced to use "git cat-file tag" + ;; instead, which inserts the signature instead of verifying + ;; it. We remove that later and then insert the verification + ;; output using "git verify-tag" (without the "-v"). + (magit-git-insert "cat-file" "tag" magit-buffer-revision) + (goto-char beg) + (forward-line 3) + (delete-region beg (point))) + (looking-at "^tagger \\([^<]+\\) <\\([^>]+\\)") + (let ((heading (format "Tagger: %s <%s>" + (match-string 1) + (match-string 2)))) + (magit-delete-line) + (magit-insert-heading + (propertize heading 'font-lock-face + 'magit-section-secondary-heading))) + (forward-line) + (magit-insert-section + ( message nil nil + :heading-highlight-face 'magit-diff-revision-summary-highlight) + (let ((beg (point))) + (forward-line) + (magit--add-face-text-property + beg (point) 'magit-diff-revision-summary)) + (magit-insert-heading) + (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max))) + (insert ?\n)) + (if (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t) + (progn + (let ((beg (match-beginning 0))) + (re-search-forward "-----END PGP SIGNATURE-----\n") + (delete-region beg (point))) + (save-excursion + (magit-process-git t "verify-tag" magit-buffer-revision)) + (magit-diff-wash-signature magit-buffer-revision)) + (goto-char (point-max))) + (insert ?\n)))) + +(defvar-keymap magit-commit-message-section-map + :doc "Keymap for `commit-message' sections." + " " #'magit-show-commit + "<1>" (magit-menu-item "Visit %t" #'magit-show-commit + '(:enable (magit-thing-at-point 'git-revision t)))) + +(defun magit-insert-revision-message () + "Insert the commit message into a revision buffer." + (magit-insert-section + ( commit-message nil nil + :heading-highlight-face 'magit-diff-revision-summary-highlight) + (if-let* ((rev magit-buffer-revision) + (msg (with-temp-buffer + (save-excursion (magit-rev-insert-format "%B" rev)) + (magit-revision--wash-message)))) + (progn + (save-excursion (insert msg)) + (magit-revision--wash-message-hashes) + (save-excursion + (magit--add-face-text-property (point) + (progn (forward-line) (point)) + 'magit-diff-revision-summary + t nil t) + (magit-insert-heading)) + (goto-char (point-max))) + (insert "(no message)\n")))) + +(defun magit-insert-revision-notes () + "Insert commit notes into a revision buffer." + (let ((default (or (magit-get "core.notesRef") "refs/notes/commits"))) + (dolist (ref (magit-list-active-notes-refs)) + (when-let* ((rev magit-buffer-revision) + (msg (with-temp-buffer + (save-excursion + (magit-git-insert "-c" (concat "core.notesRef=" ref) + "notes" "show" rev)) + (magit-revision--wash-message)))) + (magit-insert-section + ( notes ref (not (equal ref default)) + :heading-highlight-face 'magit-diff-hunk-heading-highlight) + (save-excursion (insert msg)) + (magit-revision--wash-message-hashes) + (save-excursion + (end-of-line) + (insert (format " (%s)" + (propertize (if (string-prefix-p "refs/notes/" ref) + (substring ref 11) + ref) + 'font-lock-face 'magit-refname)))) + (magit--add-face-text-property (point) + (progn (forward-line) (point)) + 'magit-diff-revision-summary + t nil t) + (magit-insert-heading) + (goto-char (point-max)) + (insert ?\n)))))) + +(defun magit-revision--wash-message () + (let ((major-mode 'git-commit-mode)) + (hack-dir-local-variables) + (hack-local-variables-apply)) + (unless (memq git-commit-major-mode '(nil text-mode)) + (funcall git-commit-major-mode) + (font-lock-ensure)) + (when (> (point-max) (point-min)) + (save-excursion + (while (search-forward "\r\n" nil t) ; Remove trailing CRs. + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + (when magit-revision-fill-summary-line + (let ((fill-column (min magit-revision-fill-summary-line + (window-width (get-buffer-window nil t))))) + (fill-region (point) (line-end-position)))) + (run-hook-wrapped 'magit-revision-wash-message-hook + (lambda (fn) (prog1 nil (save-excursion (funcall fn))))) + (buffer-string))) + +(defun magit-highlight-squash-markers () + "Highlight \"squash!\" and similar markers." + (when (looking-at "\\(?:squash!\\|fixup!\\|amend!\\)") + (magit--add-face-text-property (match-beginning 0) (match-end 0) + 'magit-keyword-squash))) + +(defun magit-highlight-bracket-keywords () + "Highlight text between brackets." + (while (re-search-forward "\\[[^][]*]" nil t) + (put-text-property (match-beginning 0) + (match-end 0) + 'font-lock-face 'magit-keyword))) + +(defun magit-revision--wash-message-hashes () + (when magit-revision-use-hash-sections + (save-excursion + ;; Start after beg to prevent a (commit text) section from + ;; starting at the same point as the (commit-message) + ;; section. + (while (not (eobp)) + (re-search-forward "\\_<" nil 'move) + (let ((beg (point))) + (re-search-forward "\\_>" nil t) + (when (> (point) beg) + (let ((text (buffer-substring-no-properties beg (point)))) + (when (pcase magit-revision-use-hash-sections + ('quickest ; false negatives and positives + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (string-match-p "[a-z]" text))) + ('quicker ; false negatives (number-less hashes) + (and (>= (length text) 7) + (string-match-p "[0-9]" text) + (magit-commit-p text))) + ('quick ; false negatives (short hashes) + (and (>= (length text) 7) + (magit-commit-p text))) + ('slow + (magit-commit-p text))) + (put-text-property beg (point) + 'font-lock-face 'magit-hash) + (let ((end (point))) + (goto-char beg) + (magit-insert-section (commit text) + (goto-char end))))))))))) + +(defun magit-insert-revision-headers () + "Insert headers about the commit into a revision buffer." + (magit-insert-section (headers) + (magit-insert-heading nil + (and-let* ((string (magit-rev-format "%D" magit-buffer-revision + "--decorate=full"))) + (concat (magit-format-ref-labels string) " ")) + (propertize + (magit-rev-parse (magit--rev-dereference magit-buffer-revision)) + 'font-lock-face 'magit-hash)) + (let ((beg (point))) + (magit-rev-insert-format magit-revision-headers-format + magit-buffer-revision) + (magit-insert-revision-gravatars magit-buffer-revision beg)) + (when magit-revision-insert-related-refs + (when (magit-revision-insert-related-refs-display-p 'parents) + (dolist (parent (magit-commit-parents magit-buffer-revision)) + (magit-insert-section (commit parent) + (let ((line (magit-rev-format "%h %s" parent))) + (string-match "^\\([^ ]+\\) \\(.*\\)" line) + (magit-bind-match-strings (hash msg) line + (insert "Parent: ") + (insert (propertize hash 'font-lock-face 'magit-hash)) + (insert " " msg "\n")))))) + (when (magit-revision-insert-related-refs-display-p 'merged) + (magit--insert-related-refs + magit-buffer-revision "--merged" "Merged" + (eq magit-revision-insert-related-refs 'all))) + (when (magit-revision-insert-related-refs-display-p 'contained) + (magit--insert-related-refs + magit-buffer-revision "--contains" "Contained" + (memq magit-revision-insert-related-refs '(all mixed)))) + (when-let (((magit-revision-insert-related-refs-display-p 'follows)) + (follows (magit-get-current-tag magit-buffer-revision t))) + (let ((tag (car follows)) + (cnt (cadr follows))) + (magit-insert-section (tag tag) + (insert + (format "Follows: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-branch-local)))))) + (when-let (((magit-revision-insert-related-refs-display-p 'precedes)) + (precedes (magit-get-next-tag magit-buffer-revision t))) + (let ((tag (car precedes)) + (cnt (cadr precedes))) + (magit-insert-section (tag tag) + (insert (format "Precedes: %s (%s)\n" + (propertize tag 'font-lock-face 'magit-tag) + (propertize (number-to-string cnt) + 'font-lock-face 'magit-tag)))))) + (insert ?\n)))) + +(defun magit-revision-insert-related-refs-display-p (sym) + "Whether to display related branches of type SYM. +Refer to user option `magit-revision-insert-related-refs-display-alist'." + (if-let ((elt (assq sym magit-revision-insert-related-refs-display-alist))) + (cdr elt) + t)) + +(defun magit--insert-related-refs (rev arg title remote) + (when-let ((refs (magit-list-related-branches arg rev (and remote "-a")))) + (magit-insert-section (related-refs) + (insert title ":" (make-string (- 10 (length title)) ?\s)) + (dolist (branch refs) + (if (<= (+ (current-column) 1 (length branch)) + (window-width)) + (insert ?\s) + (insert ?\n (make-string 12 ?\s))) + (insert (propertize branch 'font-lock-face + (if (string-prefix-p "remotes/" branch) + 'magit-branch-remote + 'magit-branch-local)))) + (insert ?\n)))) + +(defun magit-insert-revision-gravatars (rev beg) + (when (and magit-revision-show-gravatars + (window-system)) + (require 'gravatar) + (pcase-let ((`(,author . ,committer) + (pcase magit-revision-show-gravatars + ('t '("^Author: " . "^Commit: ")) + ('author '("^Author: " . nil)) + ('committer '(nil . "^Commit: ")) + (_ magit-revision-show-gravatars)))) + (when-let ((email (and author (magit-rev-format "%aE" rev)))) + (magit-insert-revision-gravatar beg rev email author)) + (when-let ((email (and committer (magit-rev-format "%cE" rev)))) + (magit-insert-revision-gravatar beg rev email committer))))) + +(defun magit-insert-revision-gravatar (beg rev email regexp) + (save-excursion + (goto-char beg) + (when-let (((re-search-forward regexp nil t)) + (window (get-buffer-window))) + (let* ((column (length (match-string 0))) + (font-obj (query-font (font-at (point) window))) + (size (* 2 (+ (aref font-obj 4) + (aref font-obj 5)))) + (align-to (+ column + (ceiling (/ size (aref font-obj 7) 1.0)) + 1)) + (gravatar-size (- size 2))) + (ignore-errors ; service may be unreachable + (gravatar-retrieve email #'magit-insert-revision-gravatar-cb + (list gravatar-size rev + (point-marker) + align-to column))))))) + +(defun magit-insert-revision-gravatar-cb (image size rev marker align-to column) + (unless (eq image 'error) + (when-let ((buffer (marker-buffer marker))) + (with-current-buffer buffer + (save-excursion + (goto-char marker) + ;; The buffer might display another revision by now or + ;; it might have been refreshed, in which case another + ;; process might already have inserted the image. + (when (and (equal rev magit-buffer-revision) + (not (eq (car-safe + (car-safe + (get-text-property (point) 'display))) + 'image))) + (setf (image-property image :ascent) 'center) + (setf (image-property image :relief) 1) + (setf (image-property image :scale) 1) + (setf (image-property image :height) size) + (let ((top (list image '(slice 0.0 0.0 1.0 0.5))) + (bot (list image '(slice 0.0 0.5 1.0 1.0))) + (align `((space :align-to ,align-to)))) + (let ((inhibit-read-only t)) + (insert (propertize " " 'display top)) + (insert (propertize " " 'display align)) + (forward-line) + (forward-char column) + (insert (propertize " " 'display bot)) + (insert (propertize " " 'display align)))))))))) + +;;; Merge-Preview Mode + +(define-derived-mode magit-merge-preview-mode magit-diff-mode "Magit Merge" + "Mode for previewing a merge." + :interactive nil + :group 'magit-diff + (magit-hack-dir-local-variables)) + +(put 'magit-merge-preview-mode 'magit-diff-default-arguments + '("--no-ext-diff")) + +(defun magit-merge-preview-setup-buffer (rev) + (magit-setup-buffer #'magit-merge-preview-mode nil + (magit-buffer-revision rev) + (magit-buffer-range (format "%s^..%s" rev rev)))) + +(defun magit-merge-preview-refresh-buffer () + (let* ((branch (magit-get-current-branch)) + (head (or branch (magit-rev-verify "HEAD")))) + (magit-set-header-line-format (format "Preview merge of %s into %s" + magit-buffer-revision + (or branch "HEAD"))) + (magit-insert-section (diffbuf) + (magit--insert-diff t + "merge-tree" (magit-git-string "merge-base" head magit-buffer-revision) + head magit-buffer-revision)))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-merge-preview-mode)) + magit-buffer-revision) + +;;; Hunk Section + +(defun magit-hunk-set-window-start (section) + "When SECTION is a `hunk', ensure that its beginning is visible. +It the SECTION has a different type, then do nothing." + (when (magit-hunk-section-p section) + (magit-section-set-window-start section))) + +(add-hook 'magit-section-movement-hook #'magit-hunk-set-window-start) + +(cl-defmethod magit-section-get-relative-position ((_section magit-hunk-section)) + (nconc (cl-call-next-method) + (and (region-active-p) + (progn + (goto-char (line-beginning-position)) + (when (looking-at "^[-+]") (forward-line)) + (while (looking-at "^[ @]") (forward-line)) + (let ((beg (magit-point))) + (list (cond + ((looking-at "^[-+]") + (forward-line) + (while (looking-at "^[-+]") (forward-line)) + (while (looking-at "^ ") (forward-line)) + (forward-line -1) + (regexp-quote (buffer-substring-no-properties + beg (line-end-position)))) + (t t)))))))) + +(cl-defmethod magit-section-goto-successor ((section magit-hunk-section) + line char &optional arg) + (or (magit-section-goto-successor--same section line char) + (and-let* ((parent (magit-get-section + (magit-section-ident + (oref section parent))))) + (let* ((children (oref parent children)) + (siblings (magit-section-siblings section 'prev)) + (previous (nth (length siblings) children))) + (if (not arg) + (when-let ((sibling (or previous (car (last children))))) + (magit-section-goto sibling) + t) + (when previous + (magit-section-goto previous)) + (if (and (stringp arg) + (re-search-forward arg (oref parent end) t)) + (goto-char (match-beginning 0)) + (goto-char (oref (car (last children)) end)) + (forward-line -1) + (while (looking-at "^ ") (forward-line -1)) + (while (looking-at "^[-+]") (forward-line -1)) + (forward-line))))) + (magit-section-goto-successor--related section))) + +;;; Diff Sections + +(defvar-keymap magit-unstaged-section-map + :doc "Keymap for the `unstaged' section." + " " #'magit-diff-unstaged + " " #'magit-stage + " " #'magit-discard + "<3>" (magit-menu-item "Discard all" #'magit-discard) + "<2>" (magit-menu-item "Stage all" #'magit-stage) + "<1>" (magit-menu-item "Visit diff" #'magit-diff-unstaged)) + +(magit-define-section-jumper magit-jump-to-unstaged + "Unstaged changes" unstaged nil magit-insert-unstaged-changes) + +(defun magit-insert-unstaged-changes () + "Insert section showing unstaged changes." + (magit-insert-section (unstaged) + (magit-insert-heading t "Unstaged changes") + (magit--insert-diff nil + "diff" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files))) + +(defvar-keymap magit-staged-section-map + :doc "Keymap for the `staged' section." + " " #'magit-reverse + " " #'magit-discard + " " #'magit-unstage + " " #'magit-diff-staged + "<4>" (magit-menu-item "Reverse all" #'magit-reverse) + "<3>" (magit-menu-item "Discard all" #'magit-discard) + "<2>" (magit-menu-item "Unstage all" #'magit-unstage) + "<1>" (magit-menu-item "Visit diff" #'magit-diff-staged)) + +(magit-define-section-jumper magit-jump-to-staged + "Staged changes" staged nil magit-insert-staged-changes) + +(defun magit-insert-staged-changes () + "Insert section showing staged changes." + ;; Avoid listing all files as deleted when visiting a bare repo. + (unless (magit-bare-repo-p) + (magit-insert-section (staged) + (magit-insert-heading t "Staged changes") + (magit--insert-diff nil + "diff" "--cached" magit-buffer-diff-args "--no-prefix" + "--" magit-buffer-diff-files)))) + +;;; Diff Type + +(defvar magit--diff-use-recorded-type-p t) + +(defun magit-diff-type (&optional section) + "Return the diff type of SECTION. + +The returned type is one of the symbols `staged', `unstaged', +`committed', or `undefined'. This type serves a similar purpose +as the general type common to all sections (which is stored in +the `type' slot of the corresponding `magit-section' struct) but +takes additional information into account. When the SECTION +isn't related to diffs and the buffer containing it also isn't +a diff-only buffer, then return nil. + +Currently the type can also be one of `tracked' and `untracked' +but these values are not handled explicitly everywhere they +should be and a possible fix could be to just return nil here. + +The section has to be a `diff' or `hunk' section, or a section +whose children are of type `diff'. If optional SECTION is nil, +return the diff type for the current section. In buffers whose +major mode is `magit-diff-mode' SECTION is ignored and the type +is determined using other means. In `magit-revision-mode' +buffers the type is always `committed'. + +Do not confuse this with `magit-diff-scope' (which see)." + (when-let ((section (or section (magit-current-section)))) + (cond ((derived-mode-p 'magit-revision-mode 'magit-stash-mode) 'committed) + ((derived-mode-p 'magit-diff-mode) + (let ((range magit-buffer-range) + (const magit-buffer-typearg)) + (cond ((and magit--diff-use-recorded-type-p + magit-buffer-diff-type)) + ((equal const "--no-index") 'undefined) + ((or (not range) + (equal range "HEAD") + (magit-rev-eq range "HEAD")) + (if (equal const "--cached") + 'staged + 'unstaged)) + ((equal const "--cached") + (if (magit-rev-head-p range) + 'staged + 'undefined)) ; i.e., committed and staged + (t 'committed)))) + ((derived-mode-p 'magit-status-mode) + (let ((stype (oref section type))) + (if (memq stype '(staged unstaged tracked untracked)) + stype + (pcase stype + ((or 'file 'module) + (let* ((parent (oref section parent)) + (type (oref parent type))) + (if (memq type '(file module)) + (magit-diff-type parent) + type))) + ('hunk (thread-first section + (oref parent) + (oref parent) + (oref type))))))) + ((derived-mode-p 'magit-log-mode) + (if (or (and (magit-section-match 'commit section) + (oref section children)) + (magit-section-match [* file commit] section)) + 'committed + 'undefined)) + (t 'undefined)))) + +(cl-defun magit-diff-scope (&optional (section nil ssection) strict) + "Return the diff scope of SECTION or the selected section(s). + +A diff's \"scope\" describes what part of a diff is selected, it is +a symbol, one of `region', `hunk', `hunks', `file', `files', or +`list'. Do not confuse this with the diff \"type\", as returned by +`magit-diff-type'. + +If optional SECTION is non-nil, then return the scope of that, +ignoring the sections selected by the region. Otherwise return +the scope of the current section, or if the region is active and +selects a valid group of diff related sections, the type of these +sections, i.e., `hunks' or `files'. If SECTION, or if that is nil +the current section, is a `hunk' section; and the region region +starts and ends inside the body of a that section, then the type +is `region'. If the region is empty after a mouse click, then +`hunk' is returned instead of `region'. + +If optional STRICT is non-nil, then return nil if the diff type of +the section at point is `untracked' or the section at point is not +actually a `diff' but a `diffstat' section." + (let ((siblings (and (not ssection) (magit-region-sections nil t)))) + (setq section (or section (car siblings) (magit-current-section))) + (when (and section + (or (not strict) + (and (not (eq (magit-diff-type section) 'untracked)) + (not (eq (and-let* ((parent (oref section parent))) + (oref parent type)) + 'diffstat))))) + (pcase (list (oref section type) + (and siblings t) + (magit-diff-use-hunk-region-p) + ssection) + (`(hunk nil t ,_) + (if (magit-section-internal-region-p section) 'region 'hunk)) + ('(hunk t t nil) 'hunks) + (`(hunk ,_ ,_ ,_) 'hunk) + ('(file t t nil) 'files) + (`(file ,_ ,_ ,_) 'file) + ('(module t t nil) 'files) + (`(module ,_ ,_ ,_) 'file) + (`(,(or 'staged 'unstaged 'untracked) nil ,_ ,_) 'list))))) + +(defun magit-diff-use-hunk-region-p () + (and (region-active-p) + ;; TODO implement this from first principals + ;; currently it's trial-and-error + (not (and (or (eq this-command #'mouse-drag-region) + (eq last-command #'mouse-drag-region) + ;; When another window was previously + ;; selected then the last-command is + ;; some byte-code function. + (byte-code-function-p last-command)) + (eq (region-end) (region-beginning)))))) + +;;; Hunk Paint + +(cl-defmethod magit-section-paint ((section magit-hunk-section) highlight) + (unless magit-diff-highlight-hunk-body + (setq highlight nil)) + (let ((end (oref section end)) + (merging (looking-at "@@@")) + (diff-type (magit-diff-type)) + (stage nil) + (tab-width (magit-diff-tab-width + (magit-section-parent-value section)))) + (forward-line) + (while (< (point) end) + (when (and magit-diff-hide-trailing-cr-characters + (char-equal ?\r (char-before (line-end-position)))) + (put-text-property (1- (line-end-position)) (line-end-position) + 'invisible t)) + (put-text-property + (point) (1+ (line-end-position)) 'font-lock-face + (cond + ((looking-at "^\\+\\+?\\([<=|>]\\)\\{7\\}") + (setq stage (pcase (list (match-string 1) highlight) + ('("<" nil) 'magit-diff-our) + ('("<" t) 'magit-diff-our-highlight) + ('("|" nil) 'magit-diff-base) + ('("|" t) 'magit-diff-base-highlight) + ('("=" nil) 'magit-diff-their) + ('("=" t) 'magit-diff-their-highlight) + ('(">" nil) nil))) + 'magit-diff-conflict-heading) + ((looking-at (if merging "^\\(\\+\\| \\+\\)" "^\\+")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'added diff-type) + (or stage + (if highlight 'magit-diff-added-highlight 'magit-diff-added))) + ((looking-at (if merging "^\\(-\\| -\\)" "^-")) + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'removed diff-type) + (if highlight 'magit-diff-removed-highlight 'magit-diff-removed)) + (t + (magit-diff-paint-tab merging tab-width) + (magit-diff-paint-whitespace merging 'context diff-type) + (if highlight 'magit-diff-context-highlight 'magit-diff-context)))) + (forward-line))) + (when (eq magit-diff-refine-hunk 'all) + (magit-diff-update-hunk-refinement section)) + (oset section painted (if highlight 'highlight 'plain))) + +(defvar magit-diff--tab-width-cache nil) + +(defun magit-diff-tab-width (file) + (setq file (expand-file-name file)) + (cl-flet ((cache (value) + (let ((elt (assoc file magit-diff--tab-width-cache))) + (if elt + (setcdr elt value) + (setq magit-diff--tab-width-cache + (cons (cons file value) + magit-diff--tab-width-cache)))) + value)) + (cond + ((not magit-diff-adjust-tab-width) + tab-width) + ((and-let* ((buffer (find-buffer-visiting file))) + (cache (buffer-local-value 'tab-width buffer)))) + ((and-let* ((elt (assoc file magit-diff--tab-width-cache))) + (or (cdr elt) + tab-width))) + ((or (eq magit-diff-adjust-tab-width 'always) + (and (numberp magit-diff-adjust-tab-width) + (>= magit-diff-adjust-tab-width + (nth 7 (file-attributes file))))) + (cache (buffer-local-value 'tab-width (find-file-noselect file)))) + (t + (cache nil) + tab-width)))) + +(defun magit-diff-paint-tab (merging width) + (save-excursion + (forward-char (if merging 2 1)) + (while (= (char-after) ?\t) + (put-text-property (point) (1+ (point)) + 'display (list (list 'space :width width))) + (forward-char)))) + +(defun magit-diff-paint-whitespace (merging line-type diff-type) + (when (and magit-diff-paint-whitespace + (or (not (memq magit-diff-paint-whitespace '(uncommitted status))) + (memq diff-type '(staged unstaged))) + (cl-case line-type + (added t) + (removed (memq magit-diff-paint-whitespace-lines '(all both))) + (context (memq magit-diff-paint-whitespace-lines '(all))))) + (let ((prefix (if merging "^[-\\+\s]\\{2\\}" "^[-\\+\s]")) + (indent + (if (local-variable-p 'magit-diff-highlight-indentation) + magit-diff-highlight-indentation + (setq-local + magit-diff-highlight-indentation + (cdr (seq-find (##string-match-p (car %) default-directory) + (nreverse + (default-value + 'magit-diff-highlight-indentation)))))))) + (when (and magit-diff-highlight-trailing + (looking-at (concat prefix ".*?\\([ \t]+\\) +?$"))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t))) + (when (or (and (eq indent 'tabs) + (looking-at (concat prefix "\\( *\t[ \t]*\\)"))) + (and (integerp indent) + (looking-at (format "%s\\([ \t]* \\{%s,\\}[ \t]*\\)" + prefix indent)))) + (let ((ov (make-overlay (match-beginning 1) (match-end 1) nil t))) + (overlay-put ov 'font-lock-face 'magit-diff-whitespace-warning) + (overlay-put ov 'priority 2) + (overlay-put ov 'evaporate t)))))) + +(cl-defmethod magit-section--refine ((section magit-hunk-section)) + (when (eq magit-diff-refine-hunk t) + (magit-diff-update-hunk-refinement section))) + +(defun magit-diff-update-hunk-refinement (&optional section allow-remove) + (if section + (unless (oref section hidden) + (pcase (list magit-diff-refine-hunk + (oref section refined) + (eq section (magit-current-section))) + ((or `(all nil ,_) '(t nil t)) + (oset section refined t) + (save-excursion + (goto-char (oref section start)) + ;; `diff-refine-hunk' does not handle combined diffs. + (unless (looking-at "@@@") + (let ((smerge-refine-ignore-whitespace + magit-diff-refine-ignore-whitespace) + ;; Avoid fsyncing many small temp files. + (write-region-inhibit-fsync t)) + (diff-refine-hunk))))) + ((and (guard allow-remove) + (or `(nil t ,_) '(t t nil))) + (oset section refined nil) + (remove-overlays (oref section start) + (oref section end) + 'diff-mode 'fine)))) + (cl-labels ((recurse (section) + (if (magit-section-match 'hunk section) + (magit-diff-update-hunk-refinement section t) + (dolist (child (oref section children)) + (recurse child))))) + (recurse magit-root-section)))) + +;;; Hunk Region + +(defun magit-diff-hunk-region-beginning () + (magit--bol-position (region-beginning))) + +(defun magit-diff-hunk-region-end () + (magit--eol-position (region-end))) + +(defun magit-diff-update-hunk-region (section) + "Highlight the hunk-internal region if any." + (when (and (eq (oref section type) 'hunk) + (eq (magit-diff-scope section t) 'region)) + (magit-diff--make-hunk-overlay + (oref section start) + (1- (oref section content)) + 'font-lock-face 'magit-diff-lines-heading + 'display (magit-diff-hunk-region-header section) + 'after-string (magit-diff--hunk-after-string 'magit-diff-lines-heading)) + (run-hook-with-args 'magit-diff-highlight-hunk-region-functions section) + t)) + +(defun magit-diff-highlight-hunk-region-dim-outside (section) + "Dim the parts of the hunk that are outside the hunk-internal region. +This is done by using the same foreground and background color +for added and removed lines as for context lines." + (let ((face (if magit-diff-highlight-hunk-body + 'magit-diff-context-highlight + 'magit-diff-context))) + (when magit-diff-unmarked-lines-keep-foreground + (setq face `(:extend t :background ,(face-attribute face :background)))) + (magit-diff--make-hunk-overlay (oref section content) + (magit-diff-hunk-region-beginning) + 'font-lock-face face + 'priority 2) + (magit-diff--make-hunk-overlay (1+ (magit-diff-hunk-region-end)) + (oref section end) + 'font-lock-face face + 'priority 2))) + +(defun magit-diff-highlight-hunk-region-using-face (_section) + "Highlight the hunk-internal region by making it bold. +Or rather highlight using the face `magit-diff-hunk-region', though +changing only the `:weight' and/or `:slant' is recommended for that +face." + (magit-diff--make-hunk-overlay (magit-diff-hunk-region-beginning) + (1+ (magit-diff-hunk-region-end)) + 'font-lock-face 'magit-diff-hunk-region)) + +(defun magit-diff-highlight-hunk-region-using-overlays (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented as single-pixel newlines places inside overlays." + (if (window-system) + (let ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (str (propertize + (concat (propertize "\s" 'display '(space :height (1))) + (propertize "\n" 'line-height t)) + 'font-lock-face 'magit-diff-lines-boundary))) + (magit-diff--make-hunk-overlay beg (1+ beg) 'before-string str) + (magit-diff--make-hunk-overlay end (1+ end) 'after-string str)) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff-highlight-hunk-region-using-underline (section) + "Emphasize the hunk-internal region using delimiting horizontal lines. +This is implemented by overlining and underlining the first and +last (visual) lines of the region." + (if (window-system) + (let* ((beg (magit-diff-hunk-region-beginning)) + (end (magit-diff-hunk-region-end)) + (beg-eol (save-excursion (goto-char beg) + (end-of-visual-line) + (point))) + (end-bol (save-excursion (goto-char end) + (beginning-of-visual-line) + (point))) + (color (face-background 'magit-diff-lines-boundary nil t))) + (cl-flet ((ln (b e &rest face) + (magit-diff--make-hunk-overlay + b e 'font-lock-face face 'after-string + (magit-diff--hunk-after-string face)))) + (if (= beg end-bol) + (ln beg beg-eol :overline color :underline color) + (ln beg beg-eol :overline color) + (ln end-bol end :underline color)))) + (magit-diff-highlight-hunk-region-using-face section))) + +(defun magit-diff--make-hunk-overlay (start end &rest args) + (let ((ov (make-overlay start end nil t))) + (overlay-put ov 'evaporate t) + (while args (overlay-put ov (pop args) (pop args))) + (push ov magit-section--region-overlays) + ov)) + +(defun magit-diff--hunk-after-string (face) + (propertize "\s" + 'font-lock-face face + 'display (list 'space :align-to + `(+ (0 . right) + ,(min (window-hscroll) + (- (line-end-position) + (line-beginning-position))))) + ;; This prevents the cursor from being rendered at the + ;; edge of the window. + 'cursor t)) + +;;; Utilities + +(defun magit-diff-inside-hunk-body-p () + "Return non-nil if point is inside the body of a hunk." + (and (magit-section-match 'hunk) + (and-let* ((content (oref (magit-current-section) content))) + (> (magit-point) content)))) + +(defun magit-diff--combined-p (section) + (cl-assert (cl-typep section 'magit-file-section)) + (string-match-p "\\`diff --\\(combined\\|cc\\)" (oref section value))) + +;;; Diff Extract + +(defun magit-diff-file-header (section &optional no-rename) + (when (magit-hunk-section-p section) + (setq section (oref section parent))) + (and (magit-file-section-p section) + (let ((header (oref section header))) + (if no-rename + (replace-regexp-in-string + "^--- \\(.+\\)" (oref section value) header t t 1) + header)))) + +(defun magit-diff-hunk-region-header (section) + (let ((patch (magit-diff-hunk-region-patch section))) + (string-match "\n" patch) + (substring patch 0 (1- (match-end 0))))) + +(defun magit-diff-hunk-region-patch (section &optional args) + (let ((op (if (member "--reverse" args) "+" "-")) + (sbeg (oref section start)) + (rbeg (magit-diff-hunk-region-beginning)) + (rend (region-end)) + (send (oref section end)) + (patch nil)) + (save-excursion + (goto-char sbeg) + (while (< (point) send) + (looking-at "\\(.\\)\\([^\n]*\n\\)") + (cond ((or (string-match-p "[@ ]" (match-string-no-properties 1)) + (and (>= (point) rbeg) + (<= (point) rend))) + (push (match-string-no-properties 0) patch)) + ((equal op (match-string-no-properties 1)) + (push (concat " " (match-string-no-properties 2)) patch))) + (forward-line))) + (let ((buffer-list-update-hook nil)) ; #3759 + (with-temp-buffer + (insert (string-join (reverse patch))) + (diff-fixup-modifs (point-min) (point-max)) + (setq patch (buffer-string)))) + patch)) + +;;; _ +(provide 'magit-diff) +;;; magit-diff.el ends here blob - /dev/null blob + 5e361ac9f3dda20ef566edd60608acca3f6a0f38 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-dired.el @@ -0,0 +1,109 @@ +;;; magit-dired.el --- Dired support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Dired support for Magit. + +;;; Code: + +(require 'magit) + +;; For `magit-do-async-shell-command'. +(declare-function dired-read-shell-command "dired-aux" (prompt arg files)) + +;;; Open Dired from Magit + +;;;###autoload +(defun magit-dired-jump (&optional other-window) + "Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'." + (interactive "P") + (dired-jump other-window + (and-let* ((file (magit-file-at-point))) + (expand-file-name (if (file-directory-p file) + (file-name-as-directory file) + file))))) + +;;; Commands for Dired Buffers + +;;;###autoload +(defun magit-dired-stage () + "In Dired, staged all marked files or the file at point." + (interactive) + (magit-stage-files (dired-get-marked-files))) + +;;;###autoload +(defun magit-dired-unstage () + "In Dired, unstaged all marked files or the file at point." + (interactive) + (magit-unstage-files (dired-get-marked-files))) + +;;;###autoload +(defun magit-dired-log (&optional follow) + "In Dired, show log for all marked files or the directory if none are marked." + (interactive "P") + (if-let ((topdir (magit-toplevel default-directory))) + (let ((args (car (magit-log-arguments))) + (files (or (dired-get-marked-files nil 'marked) + (list default-directory)))) + (when (and follow + (not (member "--follow" args)) + (not (cdr files))) + (push "--follow" args)) + (magit-log-setup-buffer + (list (or (magit-get-current-branch) "HEAD")) + args + (let ((default-directory topdir)) + (mapcar #'file-relative-name files)) + magit-log-buffer-file-locked)) + (magit--not-inside-repository-error))) + +;;;###autoload +(defun magit-dired-am-apply-patches (repo &optional arg) + "In Dired, apply the marked (or next ARG) files as patches. +If inside a repository, then apply in that. Otherwise prompt +for a repository." + (interactive (list (or (magit-toplevel) + (magit-read-repository t)) + current-prefix-arg)) + (let ((files (dired-get-marked-files nil arg nil nil t))) + (magit-status-setup-buffer repo) + (magit-am-apply-patches files))) + +;;; Miscellaneous Commands + +;;;###autoload +(defun magit-do-async-shell-command (file) + "Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point." + (interactive (list (or (magit-file-at-point) + (magit-read-file "Act on file")))) + (require 'dired-aux) + (dired-do-async-shell-command + (dired-read-shell-command "& on %s: " current-prefix-arg (list file)) + nil (list file))) + +;;; _ +(provide 'magit-dired) +;;; magit-dired.el ends here blob - /dev/null blob + 16e38b78ae50bbded19a80d332c21d7a7f2a8838 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-ediff.el @@ -0,0 +1,605 @@ +;;; magit-ediff.el --- Ediff extension for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library provides basic support for Ediff. + +;;; Code: + +(require 'magit) + +(require 'ediff) +(require 'smerge-mode) + +(defvar smerge-ediff-buf) +(defvar smerge-ediff-windows) + +;;; Options + +(defgroup magit-ediff nil + "Ediff support for Magit." + :link '(info-link "(magit)Ediffing") + :group 'magit-extensions) + +(defcustom magit-ediff-quit-hook + (list #'magit-ediff-cleanup-auxiliary-buffers + #'magit-ediff-restore-previous-winconf) + "Hooks to run after finishing Ediff, when that was invoked using Magit. +The hooks are run in the Ediff control buffer. This is similar +to `ediff-quit-hook' but takes the needs of Magit into account. +The `ediff-quit-hook' is ignored by Ediff sessions which were +invoked using Magit." + :package-version '(magit . "2.2.0") + :group 'magit-ediff + :type 'hook + :get #'magit-hook-custom-get + :options (list #'magit-ediff-cleanup-auxiliary-buffers + #'magit-ediff-restore-previous-winconf)) + +(defcustom magit-ediff-dwim-resolve-function #'magit-ediff-resolve-rest + "The function `magit-ediff-dwim' uses to resolve conflicts." + :package-version '(magit . "4.0.0") + :group 'magit-ediff + :type '(choice (const magit-ediff-resolve-rest) + (const magit-ediff-resolve-all) + (const magit-git-mergetool))) + +(defcustom magit-ediff-dwim-show-on-hunks nil + "Whether `magit-ediff-dwim' runs show variants on hunks. +If non-nil, `magit-ediff-show-staged' or +`magit-ediff-show-unstaged' are called based on what section the +hunk is in. Otherwise, `magit-ediff-dwim' runs +`magit-ediff-stage' when point is on an uncommitted hunk." + :package-version '(magit . "2.2.0") + :group 'magit-ediff + :type 'boolean) + +(defcustom magit-ediff-show-stash-with-index t + "Whether `magit-ediff-show-stash' shows the state of the index. + +If non-nil, use a third Ediff buffer to distinguish which changes +in the stash were staged. In cases where the stash contains no +staged changes, fall back to a two-buffer Ediff. + +More specifically, a stash is a merge commit, stash@{N}, with +potentially three parents. + +* stash@{N}^1 represents the `HEAD' commit at the time the stash + was created. + +* stash@{N}^2 records any changes that were staged when the stash + was made. + +* stash@{N}^3, if it exists, contains files that were untracked + when stashing. + +If this option is non-nil, `magit-ediff-show-stash' will run +Ediff on a file using three buffers: one for stash@{N}, another +for stash@{N}^1, and a third for stash@{N}^2. + +Otherwise, Ediff uses two buffers, comparing +stash@{N}^1..stash@{N}. Along with any unstaged changes, changes +in the index commit, stash@{N}^2, will be shown in this +comparison unless they conflicted with changes in the working +tree at the time of stashing." + :package-version '(magit . "2.6.0") + :group 'magit-ediff + :type 'boolean) + +(defvar magit-ediff-use-indirect-buffers nil + "Whether to use indirect buffers. +Ediff already does a lot of buffer and file shuffling and I +recommend you do not further complicate that by enabling this.") + +;;; Commands + +(defvar magit-ediff-previous-winconf nil) + +;;;###autoload (autoload 'magit-ediff "magit-ediff" nil) +(transient-define-prefix magit-ediff () + "Show differences using the Ediff package." + :info-manual "(ediff)" + ["Ediff" + [("E" "Dwim" magit-ediff-dwim) + ("s" "Stage" magit-ediff-stage)] + [("m" "Resolve rest" magit-ediff-resolve-rest) + ("M" "Resolve all conflicts" magit-ediff-resolve-all) + ("t" "Resolve using mergetool" magit-git-mergetool)] + [("u" "Show unstaged" magit-ediff-show-unstaged) + ("i" "Show staged" magit-ediff-show-staged) + ("w" "Show worktree" magit-ediff-show-working-tree)] + [("c" "Show commit" magit-ediff-show-commit) + ("r" "Show range" magit-ediff-compare) + ("z" "Show stash" magit-ediff-show-stash)]]) + +(defmacro magit-ediff-buffers (a b &optional c setup quit file) + "Run Ediff on two or three buffers. +This is a wrapper around `ediff-buffers-internal'. + +A, B and C have the form (GET-BUFFER CREATE-BUFFER). If +GET-BUFFER returns a non-nil value, then that buffer is used and +it is not killed when exiting Ediff. Otherwise CREATE-BUFFER +must return a buffer and that is killed when exiting Ediff. + +If non-nil, SETUP must be a function. It is called without +arguments after Ediff is done setting up buffers. + +If non-nil, QUIT must be a function. It is added to +`ediff-quit-hook' and is called without arguments. + +If FILE is non-nil, then perform a merge. The merge result +is put in FILE." + (let (get make kill (char ?A)) + (dolist (spec (list a b c)) + (if (not spec) + (push nil make) + (pcase-let ((`(,g ,m) spec)) + (let ((b (intern (format "buf%c" char)))) + (push `(,b ,g) get) + ;; This is an unfortunate complication that I have added for + ;; the benefit of one user. Pretend we used this instead: + ;; (push `(or ,b ,m) make) + (push `(if ,b + (if magit-ediff-use-indirect-buffers + (prog1 (make-indirect-buffer + ,b + (generate-new-buffer-name (buffer-name ,b)) + t) + (setq ,b nil)) + ,b) + ,m) + make) + (push `(unless ,b + ;; For merge jobs Ediff switches buffer names around. + ;; See (if ediff-merge-job ...) in `ediff-setup'. + (let ((var ,(if (and file (= char ?C)) + 'ediff-ancestor-buffer + (intern (format "ediff-buffer-%c" char))))) + (ediff-kill-buffer-carefully var))) + kill)) + (cl-incf char)))) + (setq get (nreverse get)) + (setq make (nreverse make)) + (setq kill (nreverse kill)) + (let ((mconf (gensym "conf")) + (mfile (gensym "file"))) + `(magit-with-toplevel + (let ((,mconf (current-window-configuration)) + (,mfile ,file) + ,@get) + (ediff-buffers-internal + ,@make + (list ,@(and setup (list setup)) + (lambda () + ;; We do not want to kill buffers that existed before + ;; Ediff was invoked, so we cannot use Ediff's default + ;; quit functions. Ediff splits quitting across two + ;; hooks for merge jobs but we only ever use one. + (setq-local ediff-quit-merge-hook nil) + (setq-local ediff-quit-hook + (list + ,@(and quit (list quit)) + (lambda () + ,@kill + (let ((magit-ediff-previous-winconf ,mconf)) + (run-hooks 'magit-ediff-quit-hook))))))) + (pcase (list ,(and c t) (and ,mfile t)) + ('(nil nil) 'ediff-buffers) + ('(nil t) 'ediff-merge-buffers) + ('(t nil) 'ediff-buffers3) + ('(t t) 'ediff-merge-buffers-with-ancestor)) + ,mfile)))))) + +;;;###autoload +(defun magit-ediff-resolve-all (file) + "Resolve all conflicts in the FILE at point using Ediff. + +If there is no file at point or if it doesn't have any unmerged +changes, then prompt for a file. + +See info node `(magit) Ediffing' for more information about this +and alternative commands." + (interactive (list (magit-read-unmerged-file))) + (magit-with-toplevel + (let* ((dir (magit-gitdir)) + (revA (or (magit-name-branch "HEAD") + (magit-commit-p "HEAD"))) + (revB (cl-find-if (##file-exists-p (expand-file-name % dir)) + '("MERGE_HEAD" "CHERRY_PICK_HEAD" "REVERT_HEAD"))) + (revB (or (magit-name-branch revB) + (magit-commit-p revB))) + (revC (magit-commit-p (magit-git-string "merge-base" revA revB))) + (fileA (magit--rev-file-name file revA revB)) + (fileB (magit--rev-file-name file revB revA)) + (fileC (or (magit--rev-file-name file revC revA) + (magit--rev-file-name file revC revB)))) + ;; Ediff assumes that the FILE where it is going to store the merge + ;; result does not exist yet, so move the existing file out of the + ;; way. If a buffer visits FILE, then we have to kill that upfront. + (when-let ((buffer (find-buffer-visiting file))) + (when (and (buffer-modified-p buffer) + (not (y-or-n-p (format "Save buffer %s %s? " + (buffer-name buffer) + "(cannot continue otherwise)")))) + (user-error "Abort")) + (kill-buffer buffer)) + (let ((orig (concat file ".ORIG"))) + (when (file-exists-p orig) + (rename-file orig (make-temp-name (concat orig "_")))) + (rename-file file orig)) + (let ((setup (lambda () + ;; Use the same conflict marker style as Git uses. + (setq-local ediff-combination-pattern + '("<<<<<<< HEAD" A + ,(format "||||||| %s" revC) Ancestor + "=======" B + ,(format ">>>>>>> %s" revB))))) + (quit (lambda () + ;; For merge jobs Ediff switches buffer names around. + ;; At this point `ediff-buffer-C' no longer refer to + ;; the ancestor buffer but to the merge result buffer. + ;; See (if ediff-merge-job ...) in `ediff-setup'. + (when (buffer-live-p ediff-buffer-C) + (with-current-buffer ediff-buffer-C + (save-buffer) + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward "^<<<<<<< " nil t) + (magit-stage-files (list file))))))))) + (if fileC + (magit-ediff-buffers + ((magit-get-revision-buffer revA fileA) + (magit-find-file-noselect revA fileA)) + ((magit-get-revision-buffer revB fileB) + (magit-find-file-noselect revB fileB)) + ((magit-get-revision-buffer revC fileC) + (magit-find-file-noselect revC fileC)) + setup quit file) + (magit-ediff-buffers + ((magit-get-revision-buffer revA fileA) + (magit-find-file-noselect revA fileA)) + ((magit-get-revision-buffer revB fileB) + (magit-find-file-noselect revB fileB)) + nil setup quit file)))))) + +;;;###autoload +(defun magit-ediff-resolve-rest (file) + "Resolve outstanding conflicts in the FILE at point using Ediff. + +If there is no file at point or if it doesn't have any unmerged +changes, then prompt for a file. + +See info node `(magit) Ediffing' for more information about this +and alternative commands." + (interactive (list (magit-read-unmerged-file))) + (magit-with-toplevel + (with-current-buffer (find-file-noselect file) + (smerge-ediff) + (setq-local + ediff-quit-hook + (lambda () + (let ((bufC ediff-buffer-C) + (bufS smerge-ediff-buf)) + (with-current-buffer bufS + (when (yes-or-no-p (format "Conflict resolution finished; save %s? " + buffer-file-name)) + (erase-buffer) + (insert-buffer-substring bufC) + (save-buffer)))) + (when (buffer-live-p ediff-buffer-A) (kill-buffer ediff-buffer-A)) + (when (buffer-live-p ediff-buffer-B) (kill-buffer ediff-buffer-B)) + (when (buffer-live-p ediff-buffer-C) (kill-buffer ediff-buffer-C)) + (when (buffer-live-p ediff-ancestor-buffer) + (kill-buffer ediff-ancestor-buffer)) + (let ((magit-ediff-previous-winconf smerge-ediff-windows)) + (run-hooks 'magit-ediff-quit-hook))))))) + +;;;###autoload +(defun magit-ediff-stage (file) + "Stage and unstage changes to FILE using Ediff. +FILE has to be relative to the top directory of the repository." + (interactive + (let ((files (magit-tracked-files))) + (list (magit-completing-read "Selectively stage file" files nil t nil nil + (car (member (magit-current-file) files)))))) + (magit-with-toplevel + (let* ((bufA (magit-get-revision-buffer "HEAD" file)) + (bufB (magit-get-revision-buffer "{index}" file)) + (lockB (and bufB (buffer-local-value 'buffer-read-only bufB))) + (bufC (get-file-buffer file)) + ;; Use the same encoding for all three buffers or we + ;; may end up changing the file in an unintended way. + (bufC* (or bufC (find-file-noselect file))) + (coding-system-for-read + (buffer-local-value 'buffer-file-coding-system bufC*)) + (bufA* (magit-find-file-noselect-1 "HEAD" file t)) + (bufB* (magit-find-file-index-noselect file t))) + (with-current-buffer bufB* (setq buffer-read-only nil)) + (magit-ediff-buffers + (bufA bufA*) + (bufB bufB*) + (bufC bufC*) + nil + (lambda () + (when (buffer-live-p ediff-buffer-B) + (when lockB + (with-current-buffer bufB (setq buffer-read-only t))) + (when (buffer-modified-p ediff-buffer-B) + (with-current-buffer ediff-buffer-B + (magit-update-index)))) + (when (and (buffer-live-p ediff-buffer-C) + (buffer-modified-p ediff-buffer-C)) + (with-current-buffer ediff-buffer-C + (when (y-or-n-p (format "Save file %s? " buffer-file-name)) + (save-buffer))))))))) + +;;;###autoload +(defun magit-ediff-compare (revA revB fileA fileB) + "Compare REVA:FILEA with REVB:FILEB using Ediff. + +FILEA and FILEB have to be relative to the top directory of the +repository. If REVA or REVB is nil, then this stands for the +working tree state. + +If the region is active, use the revisions on the first and last +line of the region. With a prefix argument, instead of diffing +the revisions, choose a revision to view changes along, starting +at the common ancestor of both revisions (i.e., use a \"...\" +range)." + (interactive + (pcase-let ((`(,revA ,revB) (magit-ediff-compare--read-revisions + nil current-prefix-arg))) + (nconc (list revA revB) + (magit-ediff-read-files revA revB)))) + (magit-ediff-buffers + ((if revA (magit-get-revision-buffer revA fileA) (get-file-buffer fileA)) + (if revA (magit-find-file-noselect revA fileA) (find-file-noselect fileA))) + ((if revB (magit-get-revision-buffer revB fileB) (get-file-buffer fileB)) + (if revB (magit-find-file-noselect revB fileB) (find-file-noselect fileB))))) + +(defun magit-ediff-compare--read-revisions (&optional arg mbase) + (let ((input (or arg (magit-diff-read-range-or-commit + "Compare range or commit" + nil mbase)))) + (if-let ((range (magit-split-range input))) + (list (car range) (cdr range)) + (list input nil)))) + +(defun magit-ediff-read-files (revA revB &optional fileB) + "Read file in REVB, return it and the corresponding file in REVA. +When FILEB is non-nil, use this as REVB's file instead of +prompting for it." + (unless (and fileB (member fileB (magit-revision-files revB))) + (setq fileB + (or (and fileB + magit-buffer-log-files + (derived-mode-p 'magit-log-mode) + (member "--follow" magit-buffer-log-args) + (cdr (assoc fileB + (magit-renamed-files + revB + (oref (car (oref magit-root-section children)) + value))))) + (magit-read-file-choice + (format "File to compare between %s and %s" + revA (or revB "the working tree")) + (magit-changed-files revA revB) + (format "No changed files between %s and %s" + revA (or revB "the working tree")))))) + (list (or (car (member fileB (magit-revision-files revA))) + (cdr (assoc fileB (magit-renamed-files revB revA))) + (magit-read-file-choice + (format "File in %s to compare with %s in %s" + revA fileB (or revB "the working tree")) + (magit-changed-files revB revA) + (format "No files have changed between %s and %s" + revA revB))) + fileB)) + +;;;###autoload +(defun magit-ediff-dwim () + "Compare, stage, or resolve using Ediff. +This command tries to guess what file, and what commit or range +the user wants to compare, stage, or resolve using Ediff. It +might only be able to guess either the file, or range or commit, +in which case the user is asked about the other. It might not +always guess right, in which case the appropriate `magit-ediff-*' +command has to be used explicitly. If it cannot read the user's +mind at all, then it asks the user for a command to run." + (interactive) + (magit-section-case + (hunk (save-excursion + (goto-char (oref (oref it parent) start)) + (magit-ediff-dwim))) + (t + (let ((range (magit-diff--dwim)) + (file (magit-current-file)) + command revA revB) + (pcase range + ((and (guard (not magit-ediff-dwim-show-on-hunks)) + (or 'unstaged 'staged)) + (setq command (if (magit-anything-unmerged-p) + magit-ediff-dwim-resolve-function + #'magit-ediff-stage))) + ('unstaged (setq command #'magit-ediff-show-unstaged)) + ('staged (setq command #'magit-ediff-show-staged)) + (`(commit . ,value) + (setq command #'magit-ediff-show-commit) + (setq revB value)) + (`(stash . ,value) + (setq command #'magit-ediff-show-stash) + (setq revB value)) + ((pred stringp) + (pcase-let ((`(,a ,b) (magit-ediff-compare--read-revisions range))) + (setq command #'magit-ediff-compare) + (setq revA a) + (setq revB b))) + (_ + (when (derived-mode-p 'magit-diff-mode) + (pcase (magit-diff-type) + ('committed (pcase-let ((`(,a ,b) + (magit-ediff-compare--read-revisions + magit-buffer-range))) + (setq revA a) + (setq revB b))) + ((guard (not magit-ediff-dwim-show-on-hunks)) + (setq command #'magit-ediff-stage)) + ('unstaged (setq command #'magit-ediff-show-unstaged)) + ('staged (setq command #'magit-ediff-show-staged)) + ('undefined (setq command nil)) + (_ (setq command nil)))))) + (cond ((not command) + (call-interactively + (magit-read-char-case + "Failed to read your mind; do you want to " t + (?c "[c]ommit" #'magit-ediff-show-commit) + (?r "[r]ange" #'magit-ediff-compare) + (?s "[s]tage" #'magit-ediff-stage) + (?m "[m] resolve remaining conflicts" + #'magit-ediff-resolve-rest) + (?M "[M] resolve all conflicts" + #'magit-ediff-resolve-all)))) + ((eq command #'magit-ediff-compare) + (apply #'magit-ediff-compare revA revB + (magit-ediff-read-files revA revB file))) + ((eq command #'magit-ediff-show-commit) + (magit-ediff-show-commit revB)) + ((eq command #'magit-ediff-show-stash) + (magit-ediff-show-stash revB)) + (file + (funcall command file)) + (t + (call-interactively command))))))) + +;;;###autoload +(defun magit-ediff-show-staged (file) + "Show staged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show staged changes for file" + (magit-staged-files) + "No staged files"))) + (magit-ediff-buffers ((magit-get-revision-buffer "HEAD" file) + (magit-find-file-noselect "HEAD" file)) + ((get-buffer (concat file ".~{index}~")) + (magit-find-file-index-noselect file t)))) + +;;;###autoload +(defun magit-ediff-show-unstaged (file) + "Show unstaged changes using Ediff. + +This only allows looking at the changes; to stage, unstage, +and discard changes using Ediff, use `magit-ediff-stage'. + +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show unstaged changes for file" + (magit-unstaged-files) + "No unstaged files"))) + (magit-ediff-buffers ((get-buffer (concat file ".~{index}~")) + (magit-find-file-index-noselect file t)) + ((get-file-buffer file) + (find-file-noselect file)))) + +;;;###autoload +(defun magit-ediff-show-working-tree (file) + "Show changes between `HEAD' and working tree using Ediff. +FILE must be relative to the top directory of the repository." + (interactive + (list (magit-read-file-choice "Show changes in file" + (magit-changed-files "HEAD") + "No changed files"))) + (magit-ediff-buffers ((magit-get-revision-buffer "HEAD" file) + (magit-find-file-noselect "HEAD" file)) + ((get-file-buffer file) + (find-file-noselect file)))) + +;;;###autoload +(defun magit-ediff-show-commit (commit) + "Show changes introduced by COMMIT using Ediff." + (interactive (list (magit-read-branch-or-commit "Revision"))) + (let ((revA (concat commit "^")) + (revB commit)) + (apply #'magit-ediff-compare + revA revB + (magit-ediff-read-files revA revB (magit-current-file))))) + +;;;###autoload +(defun magit-ediff-show-stash (stash) + "Show changes introduced by STASH using Ediff. +`magit-ediff-show-stash-with-index' controls whether a +three-buffer Ediff is used in order to distinguish changes in the +stash that were staged." + (interactive (list (magit-read-stash "Stash"))) + (pcase-let* ((revA (concat stash "^1")) + (revB (concat stash "^2")) + (revC stash) + (`(,fileA ,fileC) (magit-ediff-read-files revA revC)) + (fileB fileC)) + (if (and magit-ediff-show-stash-with-index + (member fileA (magit-changed-files revB revA))) + (magit-ediff-buffers + ((magit-get-revision-buffer revA fileA) + (magit-find-file-noselect revA fileA)) + ((magit-get-revision-buffer revB fileB) + (magit-find-file-noselect revB fileB)) + ((magit-get-revision-buffer revC fileC) + (magit-find-file-noselect revC fileC))) + (magit-ediff-compare revA revC fileA fileC)))) + +(defun magit-ediff-cleanup-auxiliary-buffers () + (let* ((ctl-buf ediff-control-buffer) + (ctl-win (ediff-get-visible-buffer-window ctl-buf)) + (ctl-frm ediff-control-frame) + (main-frame (cond ((window-live-p ediff-window-A) + (window-frame ediff-window-A)) + ((window-live-p ediff-window-B) + (window-frame ediff-window-B))))) + (ediff-kill-buffer-carefully ediff-diff-buffer) + (ediff-kill-buffer-carefully ediff-custom-diff-buffer) + (ediff-kill-buffer-carefully ediff-fine-diff-buffer) + (ediff-kill-buffer-carefully ediff-tmp-buffer) + (ediff-kill-buffer-carefully ediff-error-buffer) + (ediff-kill-buffer-carefully ediff-msg-buffer) + (ediff-kill-buffer-carefully ediff-debug-buffer) + (when (boundp 'ediff-patch-diagnostics) + (ediff-kill-buffer-carefully ediff-patch-diagnostics)) + (cond ((and (display-graphic-p) + (frame-live-p ctl-frm)) + (delete-frame ctl-frm)) + ((window-live-p ctl-win) + (delete-window ctl-win))) + (ediff-kill-buffer-carefully ctl-buf) + (when (frame-live-p main-frame) + (select-frame main-frame)))) + +(defun magit-ediff-restore-previous-winconf () + (set-window-configuration magit-ediff-previous-winconf)) + +;;; _ +(provide 'magit-ediff) +;;; magit-ediff.el ends here blob - /dev/null blob + 7e346a689a18f5fc40d66cd80c9c8fd12bae7083 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-extras.el @@ -0,0 +1,838 @@ +;;; magit-extras.el --- Additional functionality for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Additional functionality for Magit. + +;;; Code: + +(require 'magit) + +;; For `magit-project-status'. +(declare-function vc-git-command "vc-git" + (buffer okstatus file-or-list &rest flags)) + +(defvar project-prefix-map) +(defvar project-switch-commands) + +(defgroup magit-extras nil + "Additional functionality for Magit." + :group 'magit-extensions) + +;;; Git Tools +;;;; Git-Mergetool + +;;;###autoload (autoload 'magit-git-mergetool "magit-extras" nil t) +(transient-define-prefix magit-git-mergetool (file args &optional transient) + "Resolve conflicts in FILE using \"git mergetool --gui\". +With a prefix argument allow changing ARGS using a transient +popup. See info node `(magit) Ediffing' for information about +alternative commands." + :man-page "git-mergetool" + ["Settings" + ("-t" magit-git-mergetool:--tool) + ("=t" magit-merge.guitool) + ("=T" magit-merge.tool) + ("-r" magit-mergetool.hideResolved) + ("-b" magit-mergetool.keepBackup) + ("-k" magit-mergetool.keepTemporaries) + ("-w" magit-mergetool.writeToTemp)] + ["Actions" + (" m" "Invoke mergetool" magit-git-mergetool)] + (interactive + (if (and (not (eq transient-current-command 'magit-git-mergetool)) + current-prefix-arg) + (list nil nil t) + (list (magit-read-unmerged-file "Resolve") + (transient-args 'magit-git-mergetool)))) + (if transient + (transient-setup 'magit-git-mergetool) + (magit-run-git-async "mergetool" "--gui" args "--" file))) + +(transient-define-infix magit-git-mergetool:--tool () + :description "Override mergetool" + :class 'transient-option + :shortarg "-t" + :argument "--tool=" + :reader #'magit--read-mergetool) + +(transient-define-infix magit-merge.guitool () + :class 'magit--git-variable + :variable "merge.guitool" + :global t + :reader #'magit--read-mergetool) + +(transient-define-infix magit-merge.tool () + :class 'magit--git-variable + :variable "merge.tool" + :global t + :reader #'magit--read-mergetool) + +(defun magit--read-mergetool (prompt _initial-input history) + (let ((choices nil) + (lines (cdr (magit-git-lines "mergetool" "--tool-help")))) + (while (string-prefix-p "\t\t" (car lines)) + (push (substring (pop lines) 2) choices)) + (setq choices (nreverse choices)) + (magit-completing-read (or prompt "Select mergetool") + choices nil t nil history))) + +(transient-define-infix magit-mergetool.hideResolved () + :class 'magit--git-variable:boolean + :variable "mergetool.hideResolved" + :default "false" + :global t) + +(transient-define-infix magit-mergetool.keepBackup () + :class 'magit--git-variable:boolean + :variable "mergetool.keepBackup" + :default "true" + :global t) + +(transient-define-infix magit-mergetool.keepTemporaries () + :class 'magit--git-variable:boolean + :variable "mergetool.keepTemporaries" + :default "false" + :global t) + +(transient-define-infix magit-mergetool.writeToTemp () + :class 'magit--git-variable:boolean + :variable "mergetool.writeToTemp" + :default "false" + :global t) + +;;;; Git-Gui + +;;;###autoload +(defun magit-run-git-gui-blame (commit filename &optional linenum) + "Run `git gui blame' on the given FILENAME and COMMIT. +Interactively run it for the current file and the `HEAD', with a +prefix or when the current file cannot be determined let the user +choose. When the current buffer is visiting FILENAME instruct +blame to center around the line point is on." + (interactive + (let (revision filename) + (when (or current-prefix-arg + (progn + (setq revision "HEAD") + (not (setq filename (magit-file-relative-name nil 'tracked))))) + (setq revision (magit-read-branch-or-commit "Blame from revision")) + (setq filename (magit-read-file-from-rev revision "Blame file"))) + (list revision filename + (and (equal filename + (ignore-errors + (magit-file-relative-name buffer-file-name))) + (line-number-at-pos))))) + (magit-with-toplevel + (magit-process-git 0 "gui" "blame" + (and linenum (list (format "--line=%d" linenum))) + commit + filename))) + +;;;; Gitk + +(defcustom magit-gitk-executable + (or (and (eq system-type 'windows-nt) + (let ((exe (magit-git-string + "-c" "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" + "X" "gitk.exe"))) + (and exe (file-executable-p exe) exe))) + (executable-find "gitk") "gitk") + "The Gitk executable." + :group 'magit-extras + :set-after '(magit-git-executable) + :type 'string) + +;;;###autoload +(defun magit-run-git-gui () + "Run `git gui' for the current git repository." + (interactive) + (magit-with-toplevel (magit-process-git 0 "gui"))) + +;;;###autoload +(defun magit-run-gitk () + "Run `gitk' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0)) + +;;;###autoload +(defun magit-run-gitk-branches () + "Run `gitk --branches' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0 nil "--branches")) + +;;;###autoload +(defun magit-run-gitk-all () + "Run `gitk --all' in the current repository." + (interactive) + (magit-process-file magit-gitk-executable nil 0 nil "--all")) + +;;; Emacs Tools + +;;;###autoload +(defun magit-project-status () + "Run `magit-status' in the current project's root." + (interactive) + (if (fboundp 'project-root) + (magit-status-setup-buffer (project-root (project-current t))) + (user-error "`magit-project-status' requires `project' 0.3.0 or greater"))) + +(defvar magit-bind-magit-project-status t + "Whether to bind \"m\" to `magit-project-status' in `project-prefix-map'. +If so, then an entry is added to `project-switch-commands' as +well. If you want to use another key, then you must set this +to nil before loading Magit to prevent \"m\" from being bound.") + +(with-eval-after-load 'project + (when (and magit-bind-magit-project-status + ;; Added in Emacs 28.1. + (boundp 'project-prefix-map) + (boundp 'project-switch-commands) + ;; Only modify if it hasn't already been modified. + (equal project-switch-commands + (eval (car (get 'project-switch-commands 'standard-value)) + t))) + (keymap-set project-prefix-map "m" #'magit-project-status) + (add-to-list 'project-switch-commands '(magit-project-status "Magit") t))) + +;;; Shift Selection + +(defun magit--turn-on-shift-select-mode-p () + (and shift-select-mode + this-command-keys-shift-translated + (not mark-active) + (not (eq (car-safe transient-mark-mode) 'only)))) + +;;;###autoload +(defun magit-previous-line (&optional arg try-vscroll) + "Like `previous-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects an +area that is larger than the region. This causes `previous-line' +when invoked while holding the shift key to move up one line and +thereby select two lines. When invoked inside a hunk body this +command does not move point on the first invocation and thereby +it only selects a single line. Which inconsistency you prefer +is a matter of preference." + (declare (interactive-only + "use `forward-line' with negative argument instead.")) + (interactive "p\np") + (unless arg (setq arg 1)) + (let ((stay (or (magit-diff-inside-hunk-body-p) + (magit-section-position-in-heading-p)))) + (if (and stay (= arg 1) (magit--turn-on-shift-select-mode-p)) + (push-mark nil nil t) + (with-no-warnings + (handle-shift-selection) + (previous-line (if stay (max (1- arg) 1) arg) try-vscroll))))) + +;;;###autoload +(defun magit-next-line (&optional arg try-vscroll) + "Like `next-line' but with Magit-specific shift-selection. + +Magit's selection mechanism is based on the region but selects +an area that is larger than the region. This causes `next-line' +when invoked while holding the shift key to move down one line +and thereby select two lines. When invoked inside a hunk body +this command does not move point on the first invocation and +thereby it only selects a single line. Which inconsistency you +prefer is a matter of preference." + (declare (interactive-only forward-line)) + (interactive "p\np") + (unless arg (setq arg 1)) + (let ((stay (or (magit-diff-inside-hunk-body-p) + (magit-section-position-in-heading-p)))) + (if (and stay (= arg 1) (magit--turn-on-shift-select-mode-p)) + (push-mark nil nil t) + (with-no-warnings + (handle-shift-selection) + (next-line (if stay (max (1- arg) 1) arg) try-vscroll))))) + +;;; Clean + +;;;###autoload +(defun magit-clean (&optional arg) + "Remove untracked files from the working tree. +With a prefix argument also remove ignored files, +with two prefix arguments remove ignored files only. +\n(git clean -f -d [-x|-X])" + (interactive "p") + (when (yes-or-no-p (format "Remove %s files? " + (pcase arg + (1 "untracked") + (4 "untracked and ignored") + (_ "ignored")))) + (magit-wip-commit-before-change) + (magit-run-git "clean" "-f" "-d" (pcase arg (4 "-x") (16 "-X"))))) + +(put 'magit-clean 'disabled t) + +;;; ChangeLog + +;;;###autoload +(defun magit-generate-changelog (&optional amending) + "Insert ChangeLog entries into the current buffer. + +The entries are generated from the diff being committed. +If prefix argument, AMENDING, is non-nil, include changes +in HEAD as well as staged changes in the diff to check." + (interactive "P") + (unless (magit-commit-message-buffer) + (user-error "No commit in progress")) + (require 'diff-mode) ; `diff-add-log-current-defuns'. + (require 'vc-git) ; `vc-git-diff'. + (require 'add-log) ; `change-log-insert-entries'. + (setq default-directory + (if (and (file-regular-p "gitdir") + (not (magit-git-true "rev-parse" "--is-inside-work-tree")) + (magit-git-true "rev-parse" "--is-inside-git-dir")) + (file-name-directory (magit-file-line "gitdir")) + (magit-toplevel))) + (let ((rev1 (if amending "HEAD^1" "HEAD")) + (rev2 nil)) + ;; Magit may have updated the files without notifying vc, but + ;; `diff-add-log-current-defuns' relies on vc being up-to-date. + (mapc #'vc-file-clearprops (magit-staged-files)) + (change-log-insert-entries + (with-temp-buffer + (vc-git-command (current-buffer) 1 nil + "diff-index" "--exit-code" "--patch" + (and (magit-anything-staged-p) "--cached") + rev1 "--") + ;; `diff-find-source-location' consults these vars. + (defvar diff-vc-revisions) + (setq-local diff-vc-revisions (list rev1 rev2)) + (setq-local diff-vc-backend 'Git) + (diff-add-log-current-defuns))))) + +;;;###autoload +(defun magit-add-change-log-entry (&optional whoami file-name other-window) + "Find change log file and add date entry and item for current change. +This differs from `add-change-log-entry' (which see) in that +it acts on the current hunk in a Magit buffer instead of on +a position in a file-visiting buffer." + (interactive (list current-prefix-arg + (prompt-for-change-log-name))) + (pcase-let ((`(,buf ,pos) (magit-diff-visit-file--noselect))) + (magit--with-temp-position buf pos + (let ((add-log-buffer-file-name-function + (lambda () + (or magit-buffer-file-name + (buffer-file-name))))) + (add-change-log-entry whoami file-name other-window))))) + +;;;###autoload +(defun magit-add-change-log-entry-other-window (&optional whoami file-name) + "Find change log file in other window and add entry and item. +This differs from `add-change-log-entry-other-window' (which see) +in that it acts on the current hunk in a Magit buffer instead of +on a position in a file-visiting buffer." + (interactive (and current-prefix-arg + (list current-prefix-arg + (prompt-for-change-log-name)))) + (magit-add-change-log-entry whoami file-name t)) + +;;; Edit Line Commit + +;;;###autoload +(defun magit-edit-line-commit (&optional type) + "Edit the commit that added the current line. + +With a prefix argument edit the commit that removes the line, +if any. The commit is determined using `git blame' and made +editable using `git rebase --interactive' if it is reachable +from `HEAD', or by checking out the commit (or a branch that +points at it) otherwise." + (interactive (list (and current-prefix-arg 'removal))) + (let* ((chunk (magit-current-blame-chunk (or type 'addition))) + (rev (oref chunk orig-rev))) + (if (string-match-p "\\`0\\{40,\\}\\'" rev) + (message "This line has not been committed yet") + (let ((rebase (magit-rev-ancestor-p rev "HEAD")) + (file (expand-file-name (oref chunk orig-file) + (magit-toplevel)))) + (if rebase + (let ((magit--rebase-published-symbol 'edit-published)) + (magit-rebase-edit-commit rev (magit-rebase-arguments))) + (magit--checkout (or (magit-rev-branch rev) rev))) + (unless (and buffer-file-name + (file-equal-p file buffer-file-name)) + (let ((blame-type (and magit-blame-mode magit-blame-type))) + (if rebase + (set-process-sentinel + magit-this-process + (lambda (process event) + (magit-sequencer-process-sentinel process event) + (when (eq (process-status process) 'exit) + (find-file file) + (when blame-type + (magit-blame--pre-blame-setup blame-type) + (magit-blame--run (magit-blame-arguments)))))) + (find-file file) + (when blame-type + (magit-blame--pre-blame-setup blame-type) + (magit-blame--run (magit-blame-arguments)))))))))) + +(put 'magit-edit-line-commit 'disabled t) + +;;;###autoload +(defun magit-diff-edit-hunk-commit (file) + "From a hunk, edit the respective commit and visit the file. + +First visit the file being modified by the hunk at the correct +location using `magit-diff-visit-file'. This actually visits a +blob. When point is on a diff header, not within an individual +hunk, then this visits the blob the first hunk is about. + +Then invoke `magit-edit-line-commit', which uses an interactive +rebase to make the commit editable, or if that is not possible +because the commit is not reachable from `HEAD' by checking out +that commit directly. This also causes the actual worktree file +to be visited. + +Neither the blob nor the file buffer are killed when finishing +the rebase. If that is undesirable, then it might be better to +use `magit-rebase-edit-commit' instead of this command." + (interactive (list (magit-file-at-point t t))) + (let ((magit-diff-visit-previous-blob nil)) + (with-current-buffer + (magit-diff-visit-file--internal file nil #'pop-to-buffer-same-window) + (magit-edit-line-commit)))) + +(put 'magit-diff-edit-hunk-commit 'disabled t) + +;;; Reshelve + +(defcustom magit-reshelve-since-committer-only nil + "Whether `magit-reshelve-since' changes only the committer dates. +Otherwise the author dates are also changed." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +;;;###autoload +(defun magit-reshelve-since (rev keyid) + "Change the author and committer dates of the commits since REV. + +Ask the user for the first reachable commit whose dates should +be changed. Then read the new date for that commit. The initial +minibuffer input and the previous history element offer good +values. The next commit will be created one minute later and so +on. + +This command is only intended for interactive use and should only +be used on highly rearranged and unpublished history. + +If KEYID is non-nil, then use that to sign all reshelved commits. +Interactively use the value of the \"--gpg-sign\" option in the +list returned by `magit-rebase-arguments'." + (interactive (list nil + (transient-arg-value "--gpg-sign=" + (magit-rebase-arguments)))) + (let* ((current (or (magit-get-current-branch) + (user-error "Refusing to reshelve detached head"))) + (backup (concat "refs/original/refs/heads/" current))) + (cond + ((not rev) + (when (and (magit-ref-p backup) + (not (magit-y-or-n-p + (format "Backup ref %s already exists. Override? " + backup)))) + (user-error "Abort")) + (magit-log-select + (lambda (rev) + (magit-reshelve-since rev keyid)) + "Type %p on a commit to reshelve it and the commits above it,")) + (t + (cl-flet ((adjust (time offset) + (format-time-string + "%F %T %z" + (+ (floor time) + (* offset 60) + (- (car (decode-time time))))))) + (let* ((start (concat rev "^")) + (range (concat start ".." current)) + (time-rev (adjust (float-time (string-to-number + (magit-rev-format "%at" start))) + 1)) + (time-now (adjust (float-time) + (- (string-to-number + (magit-git-string "rev-list" "--count" + range)))))) + (push time-rev magit--reshelve-history) + (let ((date (floor + (float-time + (date-to-time + (read-string "Date for first commit: " + time-now 'magit--reshelve-history)))))) + (with-environment-variables (("FILTER_BRANCH_SQUELCH_WARNING" "1")) + (magit-with-toplevel + (magit-run-git-async + "filter-branch" "--force" "--env-filter" + (format + "case $GIT_COMMIT in %s\nesac" + (mapconcat + (lambda (rev) + (prog1 + (concat + (format "%s) " rev) + (and (not magit-reshelve-since-committer-only) + (format "export GIT_AUTHOR_DATE=\"%s\"; " date)) + (format "export GIT_COMMITTER_DATE=\"%s\";;" date)) + (cl-incf date 60))) + (magit-git-lines "rev-list" "--reverse" range) + " ")) + (and keyid + (list "--commit-filter" + (format "git commit-tree --gpg-sign=%s \"$@\";" + keyid))) + range "--")) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-run-git "update-ref" "-d" backup))))))))))))) + +;;; Revision Stack + +(defvar magit-revision-stack nil) + +(defcustom magit-pop-revision-stack-format + '("[%N: %h] " + "%N: %cs %H\n %s\n" + "\\[\\([0-9]+\\)[]:]") + "Control how `magit-pop-revision-stack' inserts a revision. + +The command `magit-pop-revision-stack' inserts a representation +of the revision last pushed to the `magit-revision-stack' into +the current buffer. It inserts text at point and/or near the end +of the buffer, and removes the consumed revision from the stack. + +The entries on the stack have the format (HASH TOPLEVEL) and this +option has the format (POINT-FORMAT EOB-FORMAT INDEX-REGEXP), all +of which may be nil or a string (though either one of EOB-FORMAT +or POINT-FORMAT should be a string, and if INDEX-REGEXP is +non-nil, then the two formats should be too). + +First INDEX-REGEXP is used to find the previously inserted entry, +by searching backward from point. The first submatch must match +the index number. That number is incremented by one, and becomes +the index number of the entry to be inserted. If you don't want +to number the inserted revisions, then use nil for INDEX-REGEXP. + +If INDEX-REGEXP is non-nil, then both POINT-FORMAT and EOB-FORMAT +should contain \"%N\", which is replaced with the number that was +determined in the previous step. + +Both formats, if non-nil and after removing %N, are then expanded +using `git show --format=FORMAT ...' inside TOPLEVEL. + +The expansion of POINT-FORMAT is inserted at point, and the +expansion of EOB-FORMAT is inserted at the end of the buffer (if +the buffer ends with a comment, then it is inserted right before +that)." + :package-version '(magit . "3.2.0") + :group 'magit-commands + :type '(list (choice (string :tag "Insert at point format") + (cons (string :tag "Insert at point format") + (repeat (string :tag "Argument to git show"))) + (const :tag "Don't insert at point" nil)) + (choice (string :tag "Insert at eob format") + (cons (string :tag "Insert at eob format") + (repeat (string :tag "Argument to git show"))) + (const :tag "Don't insert at eob" nil)) + (choice (regexp :tag "Find index regexp") + (const :tag "Don't number entries" nil)))) + +(defcustom magit-copy-revision-abbreviated nil + "Whether to save abbreviated revision to `kill-ring' and `magit-revision-stack'." + :package-version '(magit . "3.0.0") + :group 'magit-miscellaneous + :type 'boolean) + +;;;###autoload +(defun magit-pop-revision-stack (rev toplevel) + "Insert a representation of a revision into the current buffer. + +Pop a revision from the `magit-revision-stack' and insert it into +the current buffer according to `magit-pop-revision-stack-format'. +Revisions can be put on the stack using `magit-copy-section-value' +and `magit-copy-buffer-revision'. + +If the stack is empty or with a prefix argument, instead read a +revision in the minibuffer. By using the minibuffer history this +allows selecting an item which was popped earlier or to insert an +arbitrary reference or revision without first pushing it onto the +stack. + +When reading the revision from the minibuffer, then it might not +be possible to guess the correct repository. When this command +is called inside a repository (e.g., while composing a commit +message), then that repository is used. Otherwise (e.g., while +composing an email) then the repository recorded for the top +element of the stack is used (even though we insert another +revision). If not called inside a repository and with an empty +stack, or with two prefix arguments, then read the repository in +the minibuffer too." + (interactive + (if (or current-prefix-arg (not magit-revision-stack)) + (let ((default-directory + (or (and (not (= (prefix-numeric-value current-prefix-arg) 16)) + (or (magit-toplevel) + (cadr (car magit-revision-stack)))) + (magit-read-repository)))) + (list (magit-read-branch-or-commit "Insert revision") + default-directory)) + (push (caar magit-revision-stack) magit-revision-history) + (pop magit-revision-stack))) + (if rev + (pcase-let ((`(,pnt-format ,eob-format ,idx-format) + magit-pop-revision-stack-format)) + (let ((default-directory toplevel) + (idx (and idx-format + (save-excursion + (if (re-search-backward idx-format nil t) + (number-to-string + (1+ (string-to-number (match-string 1)))) + "1")))) + pnt-args eob-args) + (when (listp pnt-format) + (setq pnt-args (cdr pnt-format)) + (setq pnt-format (car pnt-format))) + (when (listp eob-format) + (setq eob-args (cdr eob-format)) + (setq eob-format (car eob-format))) + (when pnt-format + (when idx-format + (setq pnt-format + (string-replace "%N" idx pnt-format))) + (magit-rev-insert-format pnt-format rev pnt-args) + (delete-char -1)) + (when eob-format + (when idx-format + (setq eob-format + (string-replace "%N" idx eob-format))) + (save-excursion + (goto-char (point-max)) + (skip-syntax-backward ">-") + (beginning-of-line) + (if (and comment-start (looking-at comment-start)) + (while (looking-at comment-start) + (forward-line -1)) + (forward-line) + (unless (= (current-column) 0) + (insert ?\n))) + (insert ?\n) + (magit-rev-insert-format eob-format rev eob-args) + (delete-char -1))))) + (user-error "Revision stack is empty"))) + +;;;###autoload +(defun magit-copy-section-value (arg) + "Save the value of the current section for later use. + +Save the section value to the `kill-ring', and, provided that +the current section is a commit, branch, or tag section, push +the (referenced) revision to the `magit-revision-stack' for use +with `magit-pop-revision-stack'. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'. + +When the current section is a branch or a tag, and a prefix +argument is used, then save the revision at its tip to the +`kill-ring' instead of the reference name. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. If a prefix argument is used and the region is within +a hunk, then strip the diff marker column and keep only either +the added or removed lines, depending on the sign of the prefix +argument." + (interactive "P") + (cond + ((and arg + (magit-section-internal-region-p) + (magit-section-match 'hunk)) + (kill-new + (thread-last (buffer-substring-no-properties + (region-beginning) + (region-end)) + (replace-regexp-in-string + (format "^\\%c.*\n?" (if (< (prefix-numeric-value arg) 0) ?+ ?-)) + "") + (replace-regexp-in-string "^[ +-]" ""))) + (deactivate-mark)) + ((use-region-p) + (call-interactively #'copy-region-as-kill)) + (t + (when-let* ((section (magit-current-section)) + (value (oref section value))) + (magit-section-case + ((branch commit module-commit tag) + (let ((default-directory default-directory) ref) + (magit-section-case + ((branch tag) + (setq ref value)) + (module-commit + (setq default-directory + (file-name-as-directory + (expand-file-name (magit-section-parent-value section) + (magit-toplevel)))))) + (setq value (magit-rev-parse + (and magit-copy-revision-abbreviated "--short") + value)) + (push (list value default-directory) magit-revision-stack) + (kill-new (message "%s" (or (and current-prefix-arg ref) + value))))) + (t (kill-new (message "%s" value)))))))) + +;;;###autoload +(defun magit-copy-buffer-revision () + "Save the revision of the current buffer for later use. + +Save the revision shown in the current buffer to the `kill-ring' +and push it to the `magit-revision-stack'. + +This command is mainly intended for use in `magit-revision-mode' +buffers, the only buffers where it is always unambiguous exactly +which revision should be saved. + +Most other Magit buffers usually show more than one revision, in +some way or another, so this command has to select one of them, +and that choice might not always be the one you think would have +been the best pick. + +In such buffers it is often more useful to save the value of +the current section instead, using `magit-copy-section-value'. + +When the region is active, then save that to the `kill-ring', +like `kill-ring-save' would, instead of behaving as described +above. + +When `magit-copy-revision-abbreviated' is non-nil, save the +abbreviated revision to the `kill-ring' and the +`magit-revision-stack'." + (interactive) + (if (use-region-p) + (call-interactively #'copy-region-as-kill) + (when-let ((rev (or magit-buffer-revision + (cl-case major-mode + (magit-diff-mode + (if (string-match "\\.\\.\\.?\\(.+\\)" + magit-buffer-range) + (match-string 1 magit-buffer-range) + magit-buffer-range)) + (magit-status-mode "HEAD"))))) + (when (magit-commit-p rev) + (setq rev (magit-rev-parse + (and magit-copy-revision-abbreviated "--short") + rev)) + (push (list rev default-directory) magit-revision-stack) + (kill-new (message "%s" rev)))))) + +;;; Buffer Switching + +;;;###autoload +(defun magit-display-repository-buffer (buffer) + "Display a Magit buffer belonging to the current Git repository. +The buffer is displayed using `magit-display-buffer', which see." + (interactive (list (magit--read-repository-buffer + "Display magit buffer: "))) + (magit-display-buffer (get-buffer buffer))) + +;;;###autoload +(defun magit-switch-to-repository-buffer (buffer) + "Switch to a Magit buffer belonging to the current Git repository." + (interactive (list (magit--read-repository-buffer + "Switch to magit buffer: "))) + (switch-to-buffer buffer)) + +;;;###autoload +(defun magit-switch-to-repository-buffer-other-window (buffer) + "Switch to a Magit buffer belonging to the current Git repository." + (interactive (list (magit--read-repository-buffer + "Switch to magit buffer in another window: "))) + (switch-to-buffer-other-window buffer)) + +;;;###autoload +(defun magit-switch-to-repository-buffer-other-frame (buffer) + "Switch to a Magit buffer belonging to the current Git repository." + (interactive (list (magit--read-repository-buffer + "Switch to magit buffer in another frame: "))) + (switch-to-buffer-other-frame buffer)) + +(defun magit--read-repository-buffer (prompt) + (if-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (read-buffer + prompt (magit-get-mode-buffer 'magit-status-mode) t + (pcase-lambda (`(,_ . ,buf)) + (and buf + (with-current-buffer buf + (and (or (derived-mode-p 'magit-mode + 'magit-repolist-mode + 'magit-submodule-list-mode + 'git-rebase-mode) + (and buffer-file-name + (string-match-p git-commit-filename-regexp + buffer-file-name))) + (equal (magit-rev-parse-safe "--show-toplevel") + topdir)))))) + (user-error "Not inside a Git repository"))) + +;;; Miscellaneous + +;;;###autoload +(defun magit-abort-dwim () + "Abort current operation. +Depending on the context, this will abort a merge, a rebase, a +patch application, a cherry-pick, a revert, or a bisect." + (interactive) + (cond ((magit-merge-in-progress-p) (magit-merge-abort)) + ((magit-rebase-in-progress-p) (magit-rebase-abort)) + ((magit-am-in-progress-p) (magit-am-abort)) + ((magit-sequencer-in-progress-p) (magit-sequencer-abort)) + ((magit-bisect-in-progress-p) (magit-bisect-reset)))) + +;;;###autoload +(defun magit-back-to-indentation () + "Move point to the first non-whitespace character on this line. +In Magit diffs, also skip over - and + at the beginning of the line." + (interactive "^") + (beginning-of-line 1) + (when (and (magit-section-match 'hunk) + (looking-at (if (oref (magit-current-section) combined) + "^ ?[-+]+" + "^[-+]"))) + (goto-char (match-end 0))) + (skip-syntax-forward " " (line-end-position)) + (backward-prefix-chars)) + +;;; _ +(provide 'magit-extras) +;;; magit-extras.el ends here blob - /dev/null blob + 7ef4504b77d7af29735daa2fcf880322e1e8ed59 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-fetch.el @@ -0,0 +1,186 @@ +;;; magit-fetch.el --- Download objects and refs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements fetch commands. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-fetch "magit-fetch" nil t) +(transient-define-prefix magit-fetch () + "Fetch from another repository." + :man-page "git-fetch" + ["Arguments" + ("-p" "Prune deleted branches" ("-p" "--prune")) + ("-t" "Fetch all tags" ("-t" "--tags")) + ("-u" "Fetch full history" "--unshallow" :level 7) + ("-F" "Force" ("-f" "--force"))] + ["Fetch from" + ("p" magit-fetch-from-pushremote) + ("u" magit-fetch-from-upstream) + ("e" "elsewhere" magit-fetch-other) + ("a" "all remotes" magit-fetch-all)] + ["Fetch" + ("o" "another branch" magit-fetch-branch) + ("r" "explicit refspec" magit-fetch-refspec) + ("m" "submodules" magit-fetch-modules)] + ["Configure" + ("C" "variables..." magit-branch-configure)]) + +(defun magit-fetch-arguments () + (transient-args 'magit-fetch)) + +(defun magit-git-fetch (remote args) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "fetch" remote args)) + +;;;###autoload (autoload 'magit-fetch-from-pushremote "magit-fetch" nil t) +(transient-define-suffix magit-fetch-from-pushremote (args) + "Fetch from the current push-remote. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :description #'magit-fetch--pushremote-description + (interactive (list (magit-fetch-arguments))) + (let ((remote (magit-get-push-remote))) + (when (or current-prefix-arg + (not (member remote (magit-list-remotes)))) + (let ((var (magit--push-remote-variable))) + (setq remote + (magit-read-remote (format "Set %s and fetch from there" var))) + (magit-set remote var))) + (magit-git-fetch remote args))) + +(defun magit-fetch--pushremote-description () + (let* ((branch (magit-get-current-branch)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + ((member remote (magit-list-remotes)) remote) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-fetch-from-upstream "magit-fetch" nil t) +(transient-define-suffix magit-fetch-from-upstream (remote args) + "Fetch from the \"current\" remote, usually the upstream. + +If the upstream is configured for the current branch and names +an existing remote, then use that. Otherwise try to use another +remote: If only a single remote is configured, then use that. +Otherwise if a remote named \"origin\" exists, then use that. + +If no remote can be determined, then this command is not available +from the `magit-fetch' transient prefix and invoking it directly +results in an error." + :if (##magit-get-current-remote t) + :description (##magit-get-current-remote t) + (interactive (list (magit-get-current-remote t) + (magit-fetch-arguments))) + (unless remote + (error "The \"current\" remote could not be determined")) + (magit-git-fetch remote args)) + +;;;###autoload +(defun magit-fetch-other (remote args) + "Fetch from another repository." + (interactive (list (magit-read-remote "Fetch remote") + (magit-fetch-arguments))) + (magit-git-fetch remote args)) + +;;;###autoload +(defun magit-fetch-branch (remote branch args) + "Fetch a BRANCH from a REMOTE." + (interactive + (let ((remote (magit-read-remote-or-url "Fetch from remote or url"))) + (list remote + (magit-read-remote-branch "Fetch branch" remote) + (magit-fetch-arguments)))) + (magit-git-fetch remote (cons branch args))) + +;;;###autoload +(defun magit-fetch-refspec (remote refspec args) + "Fetch a REFSPEC from a REMOTE." + (interactive + (let ((remote (magit-read-remote-or-url "Fetch from remote or url"))) + (list remote + (magit-read-refspec "Fetch using refspec" remote) + (magit-fetch-arguments)))) + (magit-git-fetch remote (cons refspec args))) + +;;;###autoload +(defun magit-fetch-all (args) + "Fetch from all remotes." + (interactive (list (magit-fetch-arguments))) + (magit-git-fetch nil (cons "--all" args))) + +;;;###autoload +(defun magit-fetch-all-prune () + "Fetch from all remotes, and prune. +Prune remote tracking branches for branches that have been +removed on the respective remote." + (interactive) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "remote" "update" "--prune")) + +;;;###autoload +(defun magit-fetch-all-no-prune () + "Fetch from all remotes." + (interactive) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "remote" "update")) + +;;;###autoload (autoload 'magit-fetch-modules "magit-fetch" nil t) +(transient-define-prefix magit-fetch-modules (&optional transient args) + "Fetch all populated submodules. + +Fetching is done using \"git fetch --recurse-submodules\", which +means that the super-repository and recursively all submodules +are also fetched. + +To set and potentially save other arguments invoke this command +with a prefix argument." + :man-page "git-fetch" + :value (list "--verbose" "--jobs=4") + ["Arguments" + ("-v" "verbose" "--verbose") + ("-j" "number of jobs" "--jobs=" :reader transient-read-number-N+)] + ["Action" + ("m" "fetch modules" magit-fetch-modules)] + (interactive (if current-prefix-arg + (list t) + (list nil (transient-args 'magit-fetch-modules)))) + (if transient + (transient-setup 'magit-fetch-modules) + (magit-with-toplevel + (magit-run-git-async "fetch" "--recurse-submodules" args)))) + +;;; _ +(provide 'magit-fetch) +;;; magit-fetch.el ends here blob - /dev/null blob + ed65c0ea399b8fe60c42eabf5cf9eed08ed97a0d (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-files.el @@ -0,0 +1,595 @@ +;;; magit-files.el --- Finding files -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for finding blobs, staged files, +;; and Git configuration files. It also implements modes useful in +;; buffers visiting files and blobs, and the commands used by those +;; modes. + +;;; Code: + +(require 'magit) + +;;; Find Blob + +(defvar magit-find-file-hook nil) +(add-hook 'magit-find-file-hook #'magit-blob-mode) + +;;;###autoload +(defun magit-find-file (rev file) + "View FILE from REV. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go +to the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file")) + (magit-find-file--internal rev file #'pop-to-buffer-same-window)) + +;;;###autoload +(defun magit-find-file-other-window (rev file) + "View FILE from REV, in another window. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file in other window")) + (magit-find-file--internal rev file #'switch-to-buffer-other-window)) + +;;;###autoload +(defun magit-find-file-other-frame (rev file) + "View FILE from REV, in another frame. +Switch to a buffer visiting blob REV:FILE, creating one if none +already exists. If prior to calling this command the current +buffer and/or cursor position is about the same file, then go to +the line and column corresponding to that location." + (interactive (magit-find-file-read-args "Find file in other frame")) + (magit-find-file--internal rev file #'switch-to-buffer-other-frame)) + +(defun magit-find-file-read-args (prompt) + (let ((pseudo-revs '("{worktree}" "{index}"))) + (if-let ((rev (magit-completing-read "Find file from revision" + (append pseudo-revs + (magit-list-refnames nil t)) + nil nil nil 'magit-revision-history + (or (magit-branch-or-commit-at-point) + (magit-get-current-branch))))) + (list rev (magit-read-file-from-rev (if (member rev pseudo-revs) + "HEAD" + rev) + prompt)) + (user-error "Nothing selected")))) + +(defun magit-find-file--internal (rev file fn) + (let ((buf (magit-find-file-noselect rev file)) + line col) + (when-let ((visited-file (magit-file-relative-name))) + (setq line (line-number-at-pos)) + (setq col (current-column)) + (cond + ((not (equal visited-file file))) + ((equal magit-buffer-revision rev)) + ((equal rev "{worktree}") + (setq line (magit-diff-visit--offset file magit-buffer-revision line))) + ((equal rev "{index}") + (setq line (magit-diff-visit--offset file nil line))) + (magit-buffer-revision + (setq line (magit-diff-visit--offset + file (concat magit-buffer-revision ".." rev) line))) + (t + (setq line (magit-diff-visit--offset file (list "-R" rev) line))))) + (funcall fn buf) + (when line + (with-current-buffer buf + (widen) + (goto-char (point-min)) + (forward-line (1- line)) + (move-to-column col))) + buf)) + +(defun magit-find-file-noselect (rev file) + "Read FILE from REV into a buffer and return the buffer. +REV is a revision or one of \"{worktree}\" or \"{index}\". +FILE must be relative to the top directory of the repository." + (magit-find-file-noselect-1 rev file)) + +(defun magit-find-file-noselect-1 (rev file &optional revert) + "Read FILE from REV into a buffer and return the buffer. +REV is a revision or one of \"{worktree}\" or \"{index}\". +FILE must be relative to the top directory of the repository. +Non-nil REVERT means to revert the buffer. If `ask-revert', +then only after asking. A non-nil value for REVERT is ignored if REV is +\"{worktree}\"." + (if (equal rev "{worktree}") + (find-file-noselect (expand-file-name file (magit-toplevel))) + (let ((topdir (magit-toplevel))) + (when (file-name-absolute-p file) + (setq file (file-relative-name file topdir))) + (with-current-buffer (magit-get-revision-buffer-create rev file) + (when (or (not magit-buffer-file-name) + (if (eq revert 'ask-revert) + (y-or-n-p (format "%s already exists; revert it? " + (buffer-name)))) + revert) + (setq magit-buffer-revision + (if (equal rev "{index}") + "{index}" + (magit-rev-format "%H" rev))) + (setq magit-buffer-refname rev) + (setq magit-buffer-file-name (expand-file-name file topdir)) + (setq default-directory + (let ((dir (file-name-directory magit-buffer-file-name))) + (if (file-exists-p dir) dir topdir))) + (setq-local revert-buffer-function #'magit-revert-rev-file-buffer) + (revert-buffer t t) + (run-hooks (if (equal rev "{index}") + 'magit-find-index-hook + 'magit-find-file-hook))) + (current-buffer))))) + +(defun magit-get-revision-buffer-create (rev file) + (magit-get-revision-buffer rev file t)) + +(defun magit-get-revision-buffer (rev file &optional create) + (funcall (if create #'get-buffer-create #'get-buffer) + (format "%s.~%s~" file (subst-char-in-string ?/ ?_ rev)))) + +(defun magit-revert-rev-file-buffer (_ignore-auto noconfirm) + (when (or noconfirm + (and (not (buffer-modified-p)) + (catch 'found + (dolist (regexp revert-without-query) + (when (string-match regexp magit-buffer-file-name) + (throw 'found t))))) + (yes-or-no-p (format "Revert buffer from Git %s? " + (if (equal magit-buffer-refname "{index}") + "index" + (concat "revision " magit-buffer-refname))))) + (let* ((inhibit-read-only t) + (default-directory (magit-toplevel)) + (file (file-relative-name magit-buffer-file-name)) + (coding-system-for-read (or coding-system-for-read 'undecided))) + (erase-buffer) + (magit-git-insert "cat-file" "-p" + (if (equal magit-buffer-refname "{index}") + (concat ":" file) + (concat magit-buffer-refname ":" file))) + (setq buffer-file-coding-system last-coding-system-used)) + (let ((buffer-file-name magit-buffer-file-name) + (after-change-major-mode-hook + (seq-difference after-change-major-mode-hook + '(global-diff-hl-mode-enable-in-buffer ; Emacs >= 30 + global-diff-hl-mode-enable-in-buffers ; Emacs < 30 + eglot--maybe-activate-editing-mode) + #'eq))) + (normal-mode t)) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (goto-char (point-min)))) + +(define-advice lsp (:around (fn &rest args) magit-find-file) + "Do nothing when visiting blob using `magit-find-file' and similar. +See also https://github.com/doomemacs/doomemacs/pull/6309." + (unless magit-buffer-revision + (apply fn args))) + +;;; Find Index + +(defvar magit-find-index-hook nil) + +(defun magit-find-file-index-noselect (file &optional revert) + "Read FILE from the index into a buffer and return the buffer. +FILE must to be relative to the top directory of the repository." + (magit-find-file-noselect-1 "{index}" file (or revert 'ask-revert))) + +(defun magit-update-index () + "Update the index with the contents of the current buffer. +The current buffer has to be visiting a file in the index, which +is done using `magit-find-index-noselect'." + (interactive) + (let ((file (magit-file-relative-name))) + (unless (equal magit-buffer-refname "{index}") + (user-error "%s isn't visiting the index" file)) + (if (y-or-n-p (format "Update index with contents of %s?" (buffer-name))) + (let ((index (make-temp-name + (expand-file-name "magit-update-index-" (magit-gitdir)))) + (buffer (current-buffer))) + (when magit-wip-before-change-mode + (magit-wip-commit-before-change (list file) " before un-/stage")) + (unwind-protect + (progn + (let ((coding-system-for-write buffer-file-coding-system)) + (with-temp-file index + (insert-buffer-substring buffer))) + (magit-with-toplevel + (magit-call-git + "update-index" "--cacheinfo" + (substring (magit-git-string "ls-files" "-s" file) + 0 6) + (magit-git-string "hash-object" "-t" "blob" "-w" + (concat "--path=" file) + "--" (magit-convert-filename-for-git index)) + file))) + (ignore-errors (delete-file index))) + (set-buffer-modified-p nil) + (when magit-wip-after-apply-mode + (magit-wip-commit-after-apply (list file) " after un-/stage"))) + (message "Abort"))) + (when-let ((buffer (magit-get-mode-buffer 'magit-status-mode))) + (with-current-buffer buffer + (magit-refresh))) + t) + +;;; Find Config File + +(defun magit-find-git-config-file (filename &optional wildcards) + "Edit a file located in the current repository's git directory. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file', except that it temporarily +binds `default-directory' to the actual git directory, while +reading the FILENAME." + (interactive + (let ((default-directory (magit-gitdir))) + (find-file-read-args "Find file: " + (confirm-nonexistent-file-or-buffer)))) + (find-file filename wildcards)) + +(defun magit-find-git-config-file-other-window (filename &optional wildcards) + "Edit a file located in the current repo's git directory, in another window. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file-other-window', except that it +temporarily binds `default-directory' to the actual git +directory, while reading the FILENAME." + (interactive + (let ((default-directory (magit-gitdir))) + (find-file-read-args "Find file in other window: " + (confirm-nonexistent-file-or-buffer)))) + (find-file-other-window filename wildcards)) + +(defun magit-find-git-config-file-other-frame (filename &optional wildcards) + "Edit a file located in the current repo's git directory, in another frame. + +When \".git\", located at the root of the working tree, is a +regular file, then that makes it cumbersome to open a file +located in the actual git directory. + +This command is like `find-file-other-frame', except that it +temporarily binds `default-directory' to the actual git +directory, while reading the FILENAME." + (interactive + (let ((default-directory (magit-gitdir))) + (find-file-read-args "Find file in other frame: " + (confirm-nonexistent-file-or-buffer)))) + (find-file-other-frame filename wildcards)) + +;;; File Dispatch + +;;;###autoload (autoload 'magit-file-dispatch "magit" nil t) +(transient-define-prefix magit-file-dispatch () + "Invoke a Magit command that acts on the visited file. +When invoked outside a file-visiting buffer, then fall back +to `magit-dispatch'." + :info-manual "(magit) Minor Mode for Buffers Visiting Files" + [:if magit-file-relative-name + ["File actions" + (" s" "Stage" magit-file-stage :if-not-derived dired-mode) + (" s" "Stage" magit-dired-stage :if-derived dired-mode) + (" u" "Unstage" magit-file-unstage :if-not-derived dired-mode) + (" u" "Unstage" magit-dired-unstage :if-derived dired-mode) + (", x" "Untrack" magit-file-untrack) + (", r" "Rename" magit-file-rename) + (", k" "Delete" magit-file-delete) + (", c" "Checkout" magit-file-checkout)] + ["Inspect" + ("D" "Diff..." magit-diff) + ("d" "Diff" magit-diff-buffer-file)] + ["" + ("L" "Log..." magit-log) + ("l" "Log" magit-log-buffer-file :if-not-derived dired-mode) + ("l" "Log" magit-dired-log :if-derived dired-mode) + ("t" "Trace" magit-log-trace-definition) + ("M" "Merged" magit-log-merged :level 7)] + ["" + ("B" "Blame..." magit-blame) + ("b" "Blame" magit-blame-addition) + ("r" "...removal" magit-blame-removal) + ("f" "...reverse" magit-blame-reverse) + ("m" "Blame echo" magit-blame-echo) + ("q" "Quit blame" magit-blame-quit)] + ["Navigate" + ("p" "Prev blob" magit-blob-previous) + ("n" "Next blob" magit-blob-next) + ("v" "Goto blob" magit-find-file) + ("V" "Goto file" magit-blob-visit-file) + ("g" "Goto status" magit-status-here) + ("G" "Goto magit" magit-display-repository-buffer)] + ["More actions" + ("c" "Commit" magit-commit) + ("e" "Edit line" magit-edit-line-commit)]] + [:if-not magit-file-relative-name + ["File actions" + ("s" "Stage" magit-stage-files) + ("u" "Unstage" magit-unstage-files) + ("x" "Untrack" magit-file-untrack) + ("r" "Rename" magit-file-rename) + ("k" "Delete" magit-file-delete) + ("c" "Checkout" magit-file-checkout)] + ["Navigate" + ("g" "Goto status" magit-status-here :if-not-mode magit-status-mode) + ("G" "Goto magit" magit-display-repository-buffer)]]) + +;;; Blob Mode + +(defvar-keymap magit-blob-mode-map + :doc "Keymap for `magit-blob-mode'." + "p" #'magit-blob-previous + "n" #'magit-blob-next + "b" #'magit-blame-addition + "r" #'magit-blame-removal + "f" #'magit-blame-reverse + "q" #'magit-kill-this-buffer) + +(define-minor-mode magit-blob-mode + "Enable some Magit features in blob-visiting buffers. + +Currently this only adds the following key bindings. +\n\\{magit-blob-mode-map}" + :package-version '(magit . "2.3.0")) + +(defun magit-blob-next () + "Visit the next blob which modified the current file." + (interactive) + (if magit-buffer-file-name + (magit-blob-visit (or (magit-blob-successor magit-buffer-revision + magit-buffer-file-name) + magit-buffer-file-name)) + (if (buffer-file-name (buffer-base-buffer)) + (user-error "You have reached the end of time") + (user-error "Buffer isn't visiting a file or blob")))) + +(defun magit-blob-previous () + "Visit the previous blob which modified the current file." + (interactive) + (if-let ((file (or magit-buffer-file-name + (buffer-file-name (buffer-base-buffer))))) + (if-let ((ancestor (magit-blob-ancestor magit-buffer-revision file))) + (magit-blob-visit ancestor) + (user-error "You have reached the beginning of time")) + (user-error "Buffer isn't visiting a file or blob"))) + +;;;###autoload +(defun magit-blob-visit-file () + "View the file from the worktree corresponding to the current blob. +When visiting a blob or the version from the index, then go to +the same location in the respective file in the working tree." + (interactive) + (if-let ((file (magit-file-relative-name))) + (magit-find-file--internal "{worktree}" file #'pop-to-buffer-same-window) + (user-error "Not visiting a blob"))) + +(defun magit-blob-visit (blob-or-file) + (if (stringp blob-or-file) + (find-file blob-or-file) + (pcase-let ((`(,rev ,file) blob-or-file)) + (magit-find-file rev file) + (apply #'message "%s (%s %s ago)" + (magit-rev-format "%s" rev) + (magit--age (magit-rev-format "%ct" rev)))))) + +(defun magit-blob-ancestor (rev file) + (let ((lines (magit-with-toplevel + (magit-git-lines "log" "-2" "--format=%H" "--name-only" + "--follow" (or rev "HEAD") "--" file)))) + (if rev (cddr lines) (butlast lines 2)))) + +(defun magit-blob-successor (rev file) + (let ((lines (magit-with-toplevel + (magit-git-lines "log" "--format=%H" "--name-only" "--follow" + "HEAD" "--" file)))) + (catch 'found + (while lines + (if (equal (nth 2 lines) rev) + (throw 'found (list (nth 0 lines) (nth 1 lines))) + (setq lines (nthcdr 2 lines))))))) + +;;; File Commands + +;;;###autoload +(defun magit-file-stage () + "Stage all changes to the file being visited in the current buffer." + (interactive) + (unless buffer-file-name + (user-error "Not visiting a file")) + (magit-with-toplevel + (magit-stage-1 (and (magit-file-ignored-p buffer-file-name) + (if (y-or-n-p "Visited file is ignored; stage anyway?") + "--force" + (user-error "Abort"))) + (list (magit-file-relative-name))))) + +;;;###autoload +(defun magit-file-unstage () + "Unstage all changes to the file being visited in the current buffer." + (interactive) + (unless buffer-file-name + (user-error "Not visiting a file")) + (magit-with-toplevel + (magit-unstage-1 (list (magit-file-relative-name))))) + +;;;###autoload +(defun magit-file-untrack (files &optional force) + "Untrack the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +staged as well as unstaged changes." + (interactive (list (or (if-let ((files (magit-region-values 'file t))) + (if (magit-file-tracked-p (car files)) + (magit-confirm-files 'untrack files "Untrack") + (user-error "Already untracked")) + (list (magit-read-tracked-file "Untrack file")))) + current-prefix-arg)) + (magit-with-toplevel + (magit-run-git "rm" "--cached" (and force "--force") "--" files))) + +;;;###autoload +(defun magit-file-rename (file newname) + "Rename or move FILE to NEWNAME. +NEWNAME may be a file or directory name. If FILE isn't tracked in +Git, fallback to using `rename-file'." + (interactive + (let* ((file (magit-read-file "Rename file")) + (path (expand-file-name file (magit-toplevel)))) + (list path (expand-file-name + (read-file-name (format "Move %s to destination: " file) + (file-name-directory path)))))) + (let ((oldbuf (get-file-buffer file)) + (dstdir (file-name-directory newname)) + (dstfile (if (directory-name-p newname) + (concat newname (file-name-nondirectory file)) + newname))) + (when (and oldbuf (buffer-modified-p oldbuf)) + (user-error "Save %s before moving it" file)) + (when (file-exists-p dstfile) + (user-error "%s already exists" dstfile)) + (unless (file-exists-p dstdir) + (user-error "Destination directory %s does not exist" dstdir)) + (if (magit-file-tracked-p file) + (magit-call-git "mv" + (magit-convert-filename-for-git file) + (magit-convert-filename-for-git newname)) + (rename-file file newname current-prefix-arg)) + (when oldbuf + (with-current-buffer oldbuf + (let ((buffer-read-only buffer-read-only)) + (set-visited-file-name dstfile nil t)) + (if (fboundp 'vc-refresh-state) + (vc-refresh-state) + (with-no-warnings + (vc-find-file-hook)))))) + (magit-refresh)) + +;;;###autoload +(defun magit-file-delete (files &optional force) + "Delete the selected FILES or one file read in the minibuffer. + +With a prefix argument FORCE do so even when the files have +uncommitted changes. When the files aren't being tracked in +Git, then fallback to using `delete-file'." + (interactive (list (if-let ((files (magit-region-values 'file t))) + (magit-confirm-files 'delete files "Delete") + (list (magit-read-file "Delete file"))) + current-prefix-arg)) + (if (magit-file-tracked-p (car files)) + (magit-call-git "rm" (and force "--force") "--" files) + (let ((topdir (magit-toplevel))) + (dolist (file files) + (delete-file (expand-file-name file topdir) t)))) + (magit-refresh)) + +;;;###autoload +(defun magit-file-checkout (rev file) + "Checkout FILE from REV." + (interactive + (let ((rev (magit-read-branch-or-commit + "Checkout from revision" magit-buffer-revision))) + (list rev (magit-read-file-from-rev rev "Checkout file" nil t)))) + (magit-with-toplevel + (magit-run-git "checkout" rev "--" file))) + +;;; Read File + +(defvar magit-read-file-hist nil) + +(defun magit-read-file-from-rev (rev prompt &optional default include-dirs) + (let ((files (magit-revision-files rev))) + (when include-dirs + (setq files (sort (nconc files (magit-revision-directories rev)) + #'string<))) + (magit-completing-read + prompt files nil t nil 'magit-read-file-hist + (car (member (or default (magit-current-file)) files))))) + +(defun magit-read-file (prompt &optional tracked-only) + (magit-with-toplevel + (let ((choices (nconc (magit-list-files) + (and (not tracked-only) + (magit-untracked-files))))) + (magit-completing-read + prompt choices nil t nil nil + (car (member (or (magit-section-value-if '(file submodule)) + (magit-file-relative-name nil tracked-only)) + choices)))))) + +(defun magit-read-tracked-file (prompt) + (magit-read-file prompt t)) + +(defun magit-read-unmerged-file (&optional prompt) + (let ((current (magit-current-file)) + (unmerged (magit-unmerged-files))) + (unless unmerged + (user-error "There are no unresolved conflicts")) + (magit-completing-read (or prompt "Resolve file") + unmerged nil t nil nil + (car (member current unmerged))))) + +(defun magit-read-file-choice (prompt files &optional error default) + "Read file from FILES. + +If FILES has only one member, return that instead of prompting. +If FILES has no members, give a user error. ERROR can be given +to provide a more informative error. + +If DEFAULT is non-nil, use this as the default value instead of +`magit-current-file'." + (pcase (length files) + (0 (user-error (or error "No file choices"))) + (1 (car files)) + (_ (magit-completing-read + prompt files nil t nil 'magit-read-file-hist + (car (member (or default (magit-current-file)) files)))))) + +(defun magit-read-changed-file (rev-or-range prompt &optional default) + (magit-read-file-choice + prompt + (magit-changed-files rev-or-range) + default + (concat "No file changed in " rev-or-range))) + +;;; _ + +(define-obsolete-function-alias 'magit-stage-buffer-file + 'magit-file-stage "Magit 4.3.2") + +(define-obsolete-function-alias 'magit-unstage-buffer-file + 'magit-file-unstage "Magit 4.3.2") + +(provide 'magit-files) +;;; magit-files.el ends here blob - /dev/null blob + 9ff3fbeff91381686dc46a7bc14acd55ed085c03 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-git.el @@ -0,0 +1,2900 @@ +;;; magit-git.el --- Git functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements wrappers for various Git plumbing commands. + +;;; Code: + +(require 'magit-base) + +(require 'format-spec) + +;; From `magit-branch'. +(defvar magit-branch-prefer-remote-upstream) +(defvar magit-published-branches) + +;; From `magit-margin'. +(declare-function magit-maybe-make-margin-overlay "magit-margin" ()) + +;; From `magit-mode'. +(declare-function magit-get-mode-buffer "magit-mode" + (mode &optional value frame)) +(declare-function magit-refresh "magit-mode" ()) +(defvar magit-buffer-diff-type) +(defvar magit-buffer-diff-args) +(defvar magit-buffer-file-name) +(defvar magit-buffer-log-args) +(defvar magit-buffer-log-files) +(defvar magit-buffer-refname) +(defvar magit-buffer-revision) + +;; From `magit-process'. +(declare-function magit-call-git "magit-process" (&rest args)) +(declare-function magit-git "magit-process" (&rest args)) +(declare-function magit-process-buffer "magit-process" (&optional nodisplay)) +(declare-function magit-process-file "magit-process" + (process &optional infile buffer display &rest args)) +(declare-function magit-process-finish-section "magit-process" + (section exit-code)) +(declare-function magit-process-git "magit-process" (destination &rest args)) +(declare-function magit-process-insert-section "magit-process" + (pwd program args &optional errcode errlog face)) +(defvar magit-this-error) +(defvar magit-process-error-message-regexps) + +;; From `magit-status'. +(defvar magit-status-show-untracked-files) + +(eval-when-compile + (cl-pushnew 'orig-rev eieio--known-slot-names) + (cl-pushnew 'number eieio--known-slot-names)) + +;;; Options + +;; For now this is shared between `magit-process' and `magit-git'. +(defgroup magit-process nil + "Git and other external processes used by Magit." + :group 'magit) + +(defvar magit-git-environment + (list (format "INSIDE_EMACS=%s,magit" emacs-version)) + "Prepended to `process-environment' while running git.") + +(defcustom magit-git-output-coding-system + (and (eq system-type 'windows-nt) 'utf-8) + "Coding system for receiving output from Git. + +If non-nil, the Git config value `i18n.logOutputEncoding' should +be set via `magit-git-global-arguments' to value consistent with +this." + :package-version '(magit . "2.9.0") + :group 'magit-process + :type '(choice (coding-system :tag "Coding system to decode Git output") + (const :tag "Use system default" nil))) + +(defvar magit-git-w32-path-hack nil + "Alist of (EXE . (PATHENTRY)). +This specifies what additional PATH setting needs to be added to +the environment in order to run the non-wrapper git executables +successfully.") + +(defcustom magit-git-executable + (or (and (eq system-type 'windows-nt) + ;; Avoid the wrappers "cmd/git.exe" and "cmd/git.cmd", + ;; which are much slower than using "bin/git.exe" directly. + (and-let* ((exec (executable-find "git"))) + (ignore-errors + ;; Git for Windows 2.x provides cygpath so we can + ;; ask it for native paths. + (let* ((core-exe + (car + (process-lines + exec "-c" + "alias.X=!x() { which \"$1\" | cygpath -mf -; }; x" + "X" "git"))) + (hack-entry (assoc core-exe magit-git-w32-path-hack)) + ;; Running the libexec/git-core executable + ;; requires some extra PATH entries. + (path-hack + (list (concat "PATH=" + (car (process-lines + exec "-c" + "alias.P=!cygpath -wp \"$PATH\"" + "P")))))) + ;; The defcustom STANDARD expression can be + ;; evaluated many times, so make sure it is + ;; idempotent. + (if hack-entry + (setcdr hack-entry path-hack) + (push (cons core-exe path-hack) magit-git-w32-path-hack)) + core-exe)))) + (and (eq system-type 'darwin) + (executable-find "git")) + "git") + "The Git executable used by Magit on the local host. +On remote machines `magit-remote-git-executable' is used instead." + :package-version '(magit . "3.2.0") + :group 'magit-process + :type 'string) + +(defcustom magit-remote-git-executable "git" + "The Git executable used by Magit on remote machines. +On the local host `magit-git-executable' is used instead. +Consider customizing `tramp-remote-path' instead of this +option." + :package-version '(magit . "3.2.0") + :group 'magit-process + :type 'string) + +(defcustom magit-git-global-arguments + `("--no-pager" "--literal-pathspecs" + "-c" "core.preloadindex=true" + "-c" "log.showSignature=false" + "-c" "color.ui=false" + "-c" "color.diff=false" + "-c" "diff.noPrefix=false" + ,@(and (eq system-type 'windows-nt) + (list "-c" "i18n.logOutputEncoding=UTF-8"))) + "Global Git arguments. + +The arguments set here are used every time the git executable is +run as a subprocess. They are placed right after the executable +itself and before the git command - as in `git HERE... COMMAND +REST'. See the manpage `git(1)' for valid arguments. + +Be careful what you add here, especially if you are using Tramp +to connect to servers with ancient Git versions. Never remove +anything that is part of the default value, unless you really +know what you are doing. And think very hard before adding +something; it will be used every time Magit runs Git for any +purpose." + :package-version '(magit . "4.3.2") + :group 'magit-commands + :group 'magit-process + :type '(repeat string)) + +(defcustom magit-prefer-remote-upstream nil + "Whether to favor remote branches when reading the upstream branch. + +This controls whether commands that read a branch from the user +and then set it as the upstream branch, offer a local or a remote +branch as default completion candidate, when they have the choice. + +This affects all commands that use `magit-read-upstream-branch' +or `magit-read-starting-point', which includes most commands +that change the upstream and many that create new branches." + :package-version '(magit . "2.4.2") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-list-refs-namespaces + '("refs/heads" + "refs/remotes" + "refs/tags" + "refs/pullreqs") + "List of ref namespaces considered when reading a ref. + +This controls the order of refs returned by `magit-list-refs', +which is called by functions like `magit-list-branch-names' to +generate the collection of refs." + :package-version '(magit . "3.1.0") + :group 'magit-commands + :type '(repeat string)) + +(defcustom magit-list-refs-sortby nil + "How to sort the ref collection in the prompt. + +This affects commands that read a ref. More specifically, it +controls the order of refs returned by `magit-list-refs', which +is called by functions like `magit-list-branch-names' to generate +the collection of refs. By default, refs are sorted according to +their full refname (i.e., \"refs/...\"). + +Any value accepted by the `--sort' flag of \"git for-each-ref\" can +be used. For example, \"-creatordate\" places refs with more +recent committer or tagger dates earlier in the list. A list of +strings can also be given in order to pass multiple sort keys to +\"git for-each-ref\". + +Note that, depending on the completion framework you use, this +may not be sufficient to change the order in which the refs are +displayed. It only controls the order of the collection passed +to `magit-completing-read' or, for commands that support reading +multiple strings, `read-from-minibuffer'. The completion +framework ultimately determines how the collection is displayed." + :package-version '(magit . "2.11.0") + :group 'magit-miscellaneous + :type '(choice string (repeat string))) + +;;; Git + +(defvar magit-git-debug nil + "Whether and how to enable additional debugging of git errors. + +Use `magit-toggle-git-debug' (which see) to toggle the boolean value of +this variable. This can also manually be set to `include-success', in +which case successful git invocations are also logged. + +This can also be a function, which takes one argument, the error output +as a string. This is intended for internal use and is established using +let-bindings around critical code (i.e., in `magit--assert-usable-git').") + +(defun magit-toggle-git-debug () + "Toggle whether additional git errors are reported. + +Magit basically calls git for one of these two reasons: for +side-effects or to do something with its standard output. + +When git is run for side-effects then its output, including error +messages, go into the process buffer which is shown when using \ +\\\\[magit-process-buffer]. + +When git's output is consumed in some way, then it would be too +expensive to also insert it into this buffer, but with this command +that can be enabled temporarily. In that case, if git returns with +a non-zero exit status, then at least its standard error is inserted +into this buffer. + +See info node `(magit)Debugging Tools' for more information." + (interactive) + (setq magit-git-debug (not magit-git-debug)) + (message "Additional reporting of Git errors %s" + (if magit-git-debug "enabled" "disabled"))) + +(defvar magit--refresh-cache nil) + +(defmacro magit--with-refresh-cache (key &rest body) + (declare (indent 1) (debug (form body))) + (let ((k (gensym)) + (hit (gensym))) + `(if magit--refresh-cache + (let ((,k ,key)) + (if-let ((,hit (assoc ,k (cdr magit--refresh-cache)))) + (progn (cl-incf (caar magit--refresh-cache)) + (cdr ,hit)) + (cl-incf (cdar magit--refresh-cache)) + (let ((value ,(macroexp-progn body))) + (push (cons ,k value) + (cdr magit--refresh-cache)) + value))) + ,@body))) + +(defvar magit-with-editor-envvar "GIT_EDITOR" + "The environment variable exported by `magit-with-editor'. +Set this to \"GIT_SEQUENCE_EDITOR\" if you do not want to use +Emacs to edit commit messages but would like to do so to edit +rebase sequences.") + +(defmacro magit-with-editor (&rest body) + "Like `with-editor*' but let-bind some more variables. +Also respect the value of `magit-with-editor-envvar'." + (declare (indent 0) (debug (body))) + `(let ((magit-process-popup-time -1) + ;; The user may have customized `shell-file-name' to + ;; something which results in `w32-shell-dos-semantics' nil + ;; (which changes the quoting style used by + ;; `shell-quote-argument'), but Git for Windows expects shell + ;; quoting in the dos style. + (shell-file-name (if (and (eq system-type 'windows-nt) + ;; If we have Cygwin mount points, + ;; the git flavor is cygwin, so dos + ;; shell quoting is probably wrong. + (not magit-cygwin-mount-points)) + "cmdproxy" + shell-file-name))) + (with-editor* magit-with-editor-envvar + ,@body))) + +(defmacro magit--with-temp-process-buffer (&rest body) + "Like `with-temp-buffer', but always propagate `process-environment'. +When that var is buffer-local in the calling buffer, it is not +propagated by `with-temp-buffer', so we explicitly ensure that +happens, so that processes will be invoked consistently. BODY is +as for that macro." + (declare (indent 0) (debug (body))) + (let ((p (gensym))) + `(let ((,p process-environment)) + (with-temp-buffer + (setq-local process-environment ,p) + ,@body)))) + +(defsubst magit-git-executable () + "Return value of `magit-git-executable' or `magit-remote-git-executable'. +The variable is chosen depending on whether `default-directory' +is remote." + (if (file-remote-p default-directory) + magit-remote-git-executable + magit-git-executable)) + +(defun magit-process-git-arguments (args) + "Prepare ARGS for a function that invokes Git. + +Magit has many specialized functions for running Git; they all +pass arguments through this function before handing them to Git, +to do the following. + +* Flatten ARGS, removing nil arguments. +* Prepend `magit-git-global-arguments' to ARGS. +* On w32 systems, encode to `w32-ansi-code-page'." + (setq args (append magit-git-global-arguments (flatten-tree args))) + (if (and (eq system-type 'windows-nt) (boundp 'w32-ansi-code-page)) + ;; On w32, the process arguments *must* be encoded in the + ;; current code-page (see #3250). + (mapcar (lambda (arg) + (encode-coding-string + arg (intern (format "cp%d" w32-ansi-code-page)))) + args) + args)) + +(defun magit-git-exit-code (&rest args) + "Execute Git with ARGS, returning its exit code." + (magit-process-git nil args)) + +(defun magit-git-success (&rest args) + "Execute Git with ARGS, returning t if its exit code is 0." + (= (magit-git-exit-code args) 0)) + +(defun magit-git-failure (&rest args) + "Execute Git with ARGS, returning t if its exit code is 1." + (= (magit-git-exit-code args) 1)) + +(defun magit-git-string-p (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then return +nil. Neither of these results is considered an error; if that is +what you want, then use `magit-git-string-ng' instead. + +This is an experimental replacement for `magit-git-string', and +still subject to major changes." + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (and (zerop (magit-process-git t args)) + (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position))))))) + +(defun magit-git-string-ng (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If the exit code isn't zero or if there is no output, then that +is considered an error, but instead of actually signaling an +error, return nil. Additionally the output is put in the process +buffer (creating it if necessary) and the error message is shown +in the status buffer (provided it exists). + +This is an experimental replacement for `magit-git-string', and +still subject to major changes. Also see `magit-git-string-p'." + (magit--with-refresh-cache + (list default-directory 'magit-git-string-ng args) + (magit--with-temp-process-buffer + (let* ((args (magit-process-git-arguments args)) + (status (magit-process-git t args))) + (if (zerop status) + (and (not (bobp)) + (progn + (goto-char (point-min)) + (buffer-substring-no-properties + (point) (line-end-position)))) + (let ((buf (current-buffer))) + (with-current-buffer (magit-process-buffer t) + (magit-process-insert-section default-directory + magit-git-executable args + status buf + 'magit-section-secondary-heading))) + (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) + (let ((msg (magit--locate-error-message))) + (with-current-buffer status-buf + (setq magit-this-error msg)))) + nil))))) + +(defun magit-git-str (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string. Like `magit-git-string' but +ignore `magit-git-debug'." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (magit-process-git (list t nil) args) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-output (&rest args) + "Execute Git with ARGS, returning its output." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (magit-process-git (list t nil) args) + (buffer-substring-no-properties (point-min) (point-max))))) + +(define-error 'magit-invalid-git-boolean "Not a Git boolean") + +(defun magit-git-true (&rest args) + "Execute Git with ARGS, returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") t) + ((or "false" "false\n") nil) + (output (signal 'magit-invalid-git-boolean (list output))))) + +(defun magit-git-false (&rest args) + "Execute Git with ARGS, returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal `magit-invalid-git-boolean'." + (pcase (magit-git-output args) + ((or "true" "true\n") nil) + ((or "false" "false\n") t) + (output (signal 'magit-invalid-git-boolean (list output))))) + +(defun magit-git-config-p (variable &optional default) + "Return the boolean value of the Git variable VARIABLE. +VARIABLE has to be specified as a string. Return DEFAULT (which +defaults to nil) if VARIABLE is unset. If VARIABLE's value isn't +a boolean, then raise an error." + (let ((args (list "config" "--bool" "--default" (if default "true" "false") + variable))) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (let ((status (magit-process-git t args)) + (output (buffer-substring (point-min) (1- (point-max))))) + (if (zerop status) + (equal output "true") + (signal 'magit-invalid-git-boolean (list output)))))))) + +(defun magit-git-insert (&rest args) + "Execute Git with ARGS, insert stdout at point and return exit code. +If `magit-git-debug' is non-nil and the exit code is non-zero, then +insert the run command and stderr into the process buffer." + (apply #'magit--git-insert nil args)) + +(defun magit--git-insert (return-error &rest args) + (setq args (flatten-tree args)) + (if (or return-error magit-git-debug) + (let (log) + (unwind-protect + (let (exit errmsg) + (setq log (make-temp-file "magit-stderr")) + (delete-file log) + (setq exit (magit-process-git (list t log) args)) + (when (or (> exit 0) (eq magit-git-debug 'include-success)) + (when (file-exists-p log) + (with-temp-buffer + (insert-file-contents log) + (goto-char (point-max)) + (setq errmsg + (cond + ((eq return-error 'full) + (let ((str (buffer-string))) + (and (not (equal str "")) str))) + ((functionp magit-git-debug) + (funcall magit-git-debug (buffer-string))) + ((magit--locate-error-message))))) + (when magit-git-debug + (let ((magit-git-debug nil)) + (with-current-buffer (magit-process-buffer t) + (magit-process-finish-section + (magit-process-insert-section + default-directory magit-git-executable + (magit-process-git-arguments args) + exit log 'magit-section-secondary-heading) + exit))))) + (cond ((not magit-git-debug)) + (errmsg (message "%s" errmsg)) + ((zerop exit)) + ((message "Git returned with exit-code %s" exit)))) + (or errmsg exit)) + (ignore-errors (delete-file log)))) + (magit-process-git (list t nil) args))) + +(defun magit--locate-error-message () + (goto-char (point-max)) + (and (run-hook-wrapped 'magit-process-error-message-regexps + (##re-search-backward % nil t)) + (match-string-no-properties 1))) + +(defun magit-git-string (&rest args) + "Execute Git with ARGS, returning the first line of its output. +If there is no output, return nil. If the output begins with a +newline, return an empty string." + (setq args (flatten-tree args)) + (magit--with-refresh-cache (cons default-directory args) + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (unless (bobp) + (goto-char (point-min)) + (buffer-substring-no-properties (point) (line-end-position)))))) + +(defun magit-git-lines (&rest args) + "Execute Git with ARGS, returning its output as a list of lines. +Empty lines anywhere in the output are omitted. + +If Git exits with a non-zero exit status, show a message and add +a section in the respective process buffer." + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\n" t))) + +(defun magit-git-items (&rest args) + "Execute Git with ARGS, returning its null-separated output as a list. +Empty items anywhere in the output are omitted. + +If Git exits with a non-zero exit status, show a message and add +a section in the respective process buffer." + (magit--with-temp-process-buffer + (apply #'magit-git-insert args) + (split-string (buffer-string) "\0" t))) + +(defun magit-git-wash (washer &rest args) + "Execute git with ARGS, inserting washed output at point. + +First insert the raw output at point. If there is no output, call +`magit-cancel-section'. Otherwise temporarily narrow the buffer to +the inserted text, move to its beginning, and finally call function +WASHER with ARGS as its sole argument. + +If git exits with a non-zero exit status, apply the `error' face to +the error message, instead of calling WASHER. To instead cancel the +section use `magit--git-wash'." + (declare (indent 1)) + (apply #'magit--git-wash washer t args)) + +(defun magit--git-wash (washer keep-error &rest args) + "Execute git with ARGS, inserting washed output at point. + +Like `magit-git-wash' but if KEEP-ERROR is nil and an error occurs, also +insert standard error. If KEEP-ERROR is `wash-anyway', insert and wash +standard output even in case of an error." + (declare (indent 2)) + (setq args (flatten-tree args)) + (let ((beg (point)) + (exit (magit--git-insert (and keep-error 'full) args))) + (when (stringp exit) + (goto-char beg) + (insert (propertize exit 'face 'error)) + (insert (if (bolp) "\n" "\n\n"))) + (if (= (point) beg) + (magit-cancel-section) + (unless (bolp) + (insert "\n")) + (when (or (equal exit 0) + (eq keep-error 'wash-anyway)) + (save-restriction + (narrow-to-region beg (point)) + (goto-char beg) + (funcall washer args)) + (when (or (= (point) beg) + (= (point) (1+ beg))) + (magit-cancel-section)) + (magit-maybe-make-margin-overlay))) + exit)) + +(defun magit-git-executable-find (command) + "Search for COMMAND in Git's exec path, falling back to `exec-path'. +Like `executable-find', return the absolute file name of the +executable." + (or (locate-file command + (list (concat + (file-remote-p default-directory) + (or (magit-git-string "--exec-path") + (error "`git --exec-path' failed")))) + exec-suffixes + #'file-executable-p) + (compat-call executable-find command t))) + +;;; Git Version + +(defconst magit--git-version-regexp + "\\`git version \\([0-9]+\\(\\.[0-9]+\\)\\{1,2\\}\\)") + +(defvar magit--host-git-version-cache nil) + +(defun magit-git-version>= (n) + "Return t if `magit-git-version's value is greater than or equal to N." + (magit--version>= (magit-git-version) n)) + +(defun magit-git-version< (n) + "Return t if `magit-git-version's value is smaller than N." + (version< (magit-git-version) n)) + +(defun magit-git-version () + "Return the Git version used for `default-directory'. +Raise an error if Git cannot be found, if it exits with a +non-zero status, or the output does not have the expected +format." + (magit--with-refresh-cache default-directory + (let ((host (file-remote-p default-directory))) + (or (cdr (assoc host magit--host-git-version-cache)) + (magit--with-temp-process-buffer + ;; Unset global arguments for ancient Git versions. + (let* ((magit-git-global-arguments nil) + (status (magit-process-git t "version")) + (output (buffer-string))) + (cond + ((not (zerop status)) + (display-warning + 'magit + (format "%S\n\nRunning \"%s --version\" failed with output:\n\n%s" + (if host + (format "Magit cannot find Git on host %S.\n +Check the value of `magit-remote-git-executable' using +`magit-debug-git-executable' and consult the info node +`(tramp)Remote programs'." host) + "Magit cannot find Git.\n +Check the values of `magit-git-executable' and `exec-path' +using `magit-debug-git-executable'.") + (magit-git-executable) + output))) + ((save-match-data + (and (string-match magit--git-version-regexp output) + (let ((version (match-string 1 output))) + (push (cons host version) + magit--host-git-version-cache) + version)))) + ((error "Unexpected \"%s --version\" output: %S" + (magit-git-executable) + output))))))))) + +(defun magit-git-version-assert (&optional minimal who) + "Assert that the used Git version is greater than or equal to MINIMAL. +If optional MINIMAL is nil, compare with `magit--minimal-git' +instead. Optional WHO if non-nil specifies what functionality +needs at least MINIMAL, otherwise it defaults to \"Magit\"." + (when (magit-git-version< (or minimal magit--minimal-git)) + (let* ((host (file-remote-p default-directory)) + (msg (format-spec + (cond (host "\ +%w requires Git %m or greater, but on %h the version is %v. + +If multiple Git versions are installed on the host, then the +problem might be that TRAMP uses the wrong executable. + +Check the value of `magit-remote-git-executable' and consult +the info node `(tramp)Remote programs'.\n") + (t "\ +%w requires Git %m or greater, but you are using %v. + +If you have multiple Git versions installed, then check the +values of `magit-remote-git-executable' and `exec-path'.\n")) + `((?w . ,(or who "Magit")) + (?m . ,(or minimal magit--minimal-git)) + (?v . ,(magit-git-version)) + (?h . ,host))))) + (display-warning 'magit msg :error)))) + +(defun magit--safe-git-version () + "Return the Git version used for `default-directory' or an error message." + (magit--with-temp-process-buffer + (let* ((magit-git-global-arguments nil) + (status (magit-process-git t "version")) + (output (buffer-string))) + (cond ((not (zerop status)) output) + ((save-match-data + (and (string-match magit--git-version-regexp output) + (match-string 1 output)))) + (t output))))) + +(defun magit-debug-git-executable () + "Display a buffer with information about `magit-git-executable'. +Also include information about `magit-remote-git-executable'. +See info node `(magit)Debugging Tools' for more information." + (interactive) + (with-current-buffer (get-buffer-create "*magit-git-executable*") + (pop-to-buffer (current-buffer)) + (erase-buffer) + (insert (format "magit-remote-git-executable: %S\n" + magit-remote-git-executable)) + (insert (concat + (format "magit-git-executable: %S" magit-git-executable) + (and (not (file-name-absolute-p magit-git-executable)) + (format " [%S]" (executable-find magit-git-executable))) + (format " (%s)\n" (magit--safe-git-version)))) + (insert (format "exec-path: %S\n" exec-path)) + (when-let ((diff (cl-set-difference + (seq-filter #'file-exists-p (remq nil (parse-colon-path + (getenv "PATH")))) + (seq-filter #'file-exists-p (remq nil exec-path)) + :test #'file-equal-p))) + (insert (format " entries in PATH, but not in exec-path: %S\n" diff))) + (dolist (execdir exec-path) + (insert (format " %s (%s)\n" execdir (car (file-attributes execdir)))) + (when (file-directory-p execdir) + (dolist (exec (directory-files + execdir t (concat + "\\`git" (regexp-opt exec-suffixes) "\\'"))) + (insert (format " %s (%s)\n" exec + (magit--safe-git-version)))))))) + +;;; Variables + +(defun magit-config-get-from-cached-list (key) + (gethash + ;; `git config --list' downcases first and last components of the key. + (let* ((key (replace-regexp-in-string "\\`[^.]+" #'downcase key t t)) + (key (replace-regexp-in-string "[^.]+\\'" #'downcase key t t))) + key) + (magit--with-refresh-cache (cons (magit-toplevel) 'config) + (let ((configs (make-hash-table :test #'equal))) + (dolist (conf (magit-git-items "config" "--list" "-z")) + (let* ((nl-pos (cl-position ?\n conf)) + (key (substring conf 0 nl-pos)) + (val (if nl-pos (substring conf (1+ nl-pos)) ""))) + (puthash key (nconc (gethash key configs) (list val)) configs))) + configs)))) + +(defun magit-get (&rest keys) + "Return the value of the Git variable specified by KEYS." + (car (last (apply #'magit-get-all keys)))) + +(defun magit-get-all (&rest keys) + "Return all values of the Git variable specified by KEYS." + (let ((magit-git-debug nil) + (arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (if (and magit--refresh-cache (not arg)) + (magit-config-get-from-cached-list key) + (magit-git-items "config" arg "-z" "--get-all" "--include" key)))) + +(defun magit-get-boolean (&rest keys) + "Return the boolean value of the Git variable specified by KEYS. +Also see `magit-git-config-p'." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (equal (if magit--refresh-cache + (car (last (magit-config-get-from-cached-list key))) + (magit-git-str "config" arg "--bool" "--include" key)) + "true"))) + +(defun magit-set (value &rest keys) + "Set the value of the Git variable specified by KEYS to VALUE." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (key (string-join keys "."))) + (if value + (magit-git-success "config" arg key value) + (magit-git-success "config" arg "--unset" key)) + value)) + +(gv-define-setter magit-get (val &rest keys) + `(magit-set ,val ,@keys)) + +(defun magit-set-all (values &rest keys) + "Set all values of the Git variable specified by KEYS to VALUES." + (let ((arg (and (or (null (car keys)) + (string-prefix-p "--" (car keys))) + (pop keys))) + (var (string-join keys "."))) + (when (magit-get var) + (magit-call-git "config" arg "--unset-all" var)) + (dolist (v values) + (magit-call-git "config" arg "--add" var v)))) + +;;; Files + +(defun magit--safe-default-directory (&optional file) + (catch 'unsafe-default-dir + (let ((dir (file-name-as-directory + (expand-file-name (or file default-directory)))) + (previous nil)) + (while (not (file-accessible-directory-p dir)) + (setq dir (file-name-directory (directory-file-name dir))) + (when (equal dir previous) + (throw 'unsafe-default-dir nil)) + (setq previous dir)) + dir))) + +(defmacro magit--with-safe-default-directory (file &rest body) + (declare (indent 1) (debug (form body))) + `(when-let ((default-directory (magit--safe-default-directory ,file))) + ,@body)) + +(defun magit-git-dir (&optional path) + "Like (expand-file-name PATH (magit-gitdir)) or just (magit-gitdir)." + (declare (obsolete magit-gitdir "Magit 4.0.0")) + (and-let* ((dir (magit-gitdir))) + (if path + (expand-file-name (convert-standard-filename path) dir) + dir))) + +(defun magit-gitdir (&optional directory) + "Return the absolute and resolved path of the .git directory. + +If the `GIT_DIR' environment variable is defined, return that. +Otherwise return the .git directory for DIRECTORY, or if that is +nil, then for `default-directory' instead. If the directory is +not located inside a Git repository, then return nil." + (let ((default-directory (or directory default-directory))) + (magit--with-refresh-cache (list default-directory 'magit-gitdir) + (magit--with-safe-default-directory nil + (and-let* + ((dir (magit-rev-parse-safe "--git-dir")) + (dir (file-name-as-directory (magit-expand-git-file-name dir)))) + (if (file-remote-p dir) + dir + (concat (file-remote-p default-directory) dir))))))) + +(defvar magit--separated-gitdirs nil) + +(defun magit--record-separated-gitdir () + (let ((topdir (magit-toplevel)) + (gitdir (magit-gitdir))) + ;; Kludge: git-annex converts submodule gitdirs to symlinks. See #3599. + (when (file-symlink-p (directory-file-name gitdir)) + (setq gitdir (file-truename gitdir))) + ;; We want to delete the entry for `topdir' here, rather than within + ;; (unless ...), in case a `--separate-git-dir' repository was switched to + ;; the standard structure (i.e., "topdir/.git/"). + (setq magit--separated-gitdirs (cl-delete topdir + magit--separated-gitdirs + :key #'car :test #'equal)) + (unless (equal (file-name-as-directory (expand-file-name ".git" topdir)) + gitdir) + (push (cons topdir gitdir) magit--separated-gitdirs)))) + +(defun magit-toplevel (&optional directory) + "Return the absolute path to the toplevel of the current repository. + +From within the working tree or control directory of a repository +return the absolute path to the toplevel directory of the working +tree. As a special case, from within a bare repository return +the control directory instead. When called outside a repository +then return nil. + +When optional DIRECTORY is non-nil then return the toplevel for +that directory instead of the one for `default-directory'. + +Try to respect the option `find-file-visit-truename', i.e., when +the value of that option is nil, then avoid needlessly returning +the truename. When a symlink to a sub-directory of the working +tree is involved, or when called from within a sub-directory of +the gitdir or from the toplevel of a gitdir, which itself is not +located within the working tree, then it is not possible to avoid +returning the truename." + (or + (magit--with-refresh-cache + (cons (or directory default-directory) 'magit-toplevel) + (magit--with-safe-default-directory directory + (if-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (let (updir) + (setq topdir (magit-expand-git-file-name topdir)) + (cond + ((and + ;; Always honor these settings. + (not find-file-visit-truename) + (not (getenv "GIT_WORK_TREE")) + ;; `--show-cdup' is the relative path to the toplevel + ;; from `(file-truename default-directory)'. Here we + ;; pretend it is relative to `default-directory', and + ;; go to that directory. Then we check whether + ;; `--show-toplevel' still returns the same value and + ;; whether `--show-cdup' now is the empty string. If + ;; both is the case, then we are at the toplevel of + ;; the same working tree, but also avoided needlessly + ;; following any symlinks. + (progn + (setq updir (file-name-as-directory + (magit-rev-parse-safe "--show-cdup"))) + (setq updir (if (file-name-absolute-p updir) + (concat (file-remote-p default-directory) + updir) + (expand-file-name updir))) + (and-let* + ((default-directory updir) + (top (and (string-equal + (magit-rev-parse-safe "--show-cdup") "") + (magit-rev-parse-safe "--show-toplevel")))) + (string-equal (magit-expand-git-file-name top) topdir)))) + updir) + ((concat (file-remote-p default-directory) + (file-name-as-directory topdir))))) + (and-let* ((gitdir (magit-rev-parse-safe "--git-dir")) + (gitdir (file-name-as-directory + (if (file-name-absolute-p gitdir) + ;; We might have followed a symlink. + (concat (file-remote-p default-directory) + (magit-expand-git-file-name gitdir)) + (expand-file-name gitdir))))) + (if (magit-bare-repo-p) + gitdir + (let* ((link (expand-file-name "gitdir" gitdir)) + (wtree (and (file-exists-p link) + (magit-file-line link)))) + (cond + ((and wtree + ;; Ignore .git/gitdir files that result from a + ;; Git bug. See #2364. + (not (equal wtree ".git"))) + ;; Return the linked working tree. + (concat (file-remote-p default-directory) + (file-name-directory wtree))) + ;; The working directory may not be the parent + ;; directory of .git if it was set up with + ;; "git init --separate-git-dir". See #2955. + ((car (rassoc gitdir magit--separated-gitdirs))) + (;; Step outside the control directory to enter the + ;; working tree. + (file-name-directory (directory-file-name gitdir)))))))))))) + +(defun magit--toplevel-safe () + (or (magit-toplevel) + (magit--not-inside-repository-error))) + +(defmacro magit-with-toplevel (&rest body) + (declare (indent defun) (debug (body))) + `(let ((default-directory (magit--toplevel-safe))) + ,@body)) + +(define-error 'magit-outside-git-repo "Not inside Git repository") +(define-error 'magit-corrupt-git-config "Corrupt Git configuration") +(define-error 'magit-git-executable-not-found + (concat "Git executable cannot be found " + "(see https://magit.vc/goto/e6a78ed2)")) + +(defun magit--assert-usable-git () + (if (not (compat-call executable-find (magit-git-executable) t)) + (signal 'magit-git-executable-not-found (magit-git-executable)) + (let ((magit-git-debug + (lambda (err) + (signal 'magit-corrupt-git-config + (format "%s: %s" default-directory err))))) + ;; This should always succeed unless there's a corrupt config + ;; (or at least a similarly severe failing state). Note that + ;; git-config's --default is avoided because it's not available + ;; until Git 2.18. + (magit-git-string "config" "--get-color" "" "reset")) + nil)) + +(defun magit--not-inside-repository-error () + (magit--assert-usable-git) + (signal 'magit-outside-git-repo default-directory)) + +(defun magit-inside-gitdir-p (&optional noerror) + "Return t if `default-directory' is below the repository directory. +If it is below the working directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + ;; Below a repository directory that is not located below the + ;; working directory "git rev-parse --is-inside-git-dir" prints + ;; "false", which is wrong. + (let ((gitdir (magit-gitdir))) + (cond (gitdir (file-in-directory-p default-directory gitdir)) + (noerror nil) + ((signal 'magit-outside-git-repo default-directory)))))) + +(defun magit-inside-worktree-p (&optional noerror) + "Return t if `default-directory' is below the working directory. +If it is below the repository directory, then return nil. +If it isn't below either, then signal an error unless NOERROR +is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-inside-work-tree") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(cl-defgeneric magit-bare-repo-p (&optional noerror) + "Return t if the current repository is bare. +If it is non-bare, then return nil. If `default-directory' +isn't below a Git repository, then signal an error unless +NOERROR is non-nil, in which case return nil." + (and (magit--assert-default-directory noerror) + (condition-case nil + (magit-rev-parse-true "--is-bare-repository") + (magit-invalid-git-boolean + (and (not noerror) + (signal 'magit-outside-git-repo default-directory)))))) + +(defun magit--assert-default-directory (&optional noerror) + (or (file-directory-p default-directory) + (and (not noerror) + (let ((exists (file-exists-p default-directory))) + (signal (if exists 'file-error 'file-missing) + (list "Running git in directory" + (if exists + "Not a directory" + "No such file or directory") + default-directory)))))) + +(defun magit-git-repo-p (directory &optional non-bare) + "Return t if DIRECTORY is a Git repository. +When optional NON-BARE is non-nil also return nil if DIRECTORY is +a bare repository." + (and (file-directory-p directory) ; Avoid archives, see #3397. + (or (file-regular-p (expand-file-name ".git" directory)) + (file-directory-p (expand-file-name ".git" directory)) + (and (not non-bare) + (file-regular-p (expand-file-name "HEAD" directory)) + (file-directory-p (expand-file-name "refs" directory)) + (file-directory-p (expand-file-name "objects" directory)))))) + +(defun magit-file-relative-name (&optional file tracked) + "Return the path of FILE relative to the repository root. + +If optional FILE is nil or omitted, return the relative path of +the file being visited in the current buffer, if any, else nil. +If the file is not inside a Git repository, then return nil. + +If TRACKED is non-nil, return the path only if it matches a +tracked file." + (and-let* ((file (or file + magit-buffer-file-name + buffer-file-name + (and (derived-mode-p 'dired-mode) + default-directory))) + ((or (not tracked) + (magit-file-tracked-p (file-relative-name file)))) + (dir (magit-toplevel + (magit--safe-default-directory + (directory-file-name (file-name-directory file)))))) + (file-relative-name file dir))) + +(defun magit-file-ignored-p (file) + (magit-git-string-p "ls-files" "--others" "--ignored" "--exclude-standard" + "--" (magit-convert-filename-for-git file))) + +(defun magit-file-tracked-p (file) + (magit-git-success "ls-files" "--error-unmatch" + "--" (magit-convert-filename-for-git file))) + +(defun magit-list-files (&rest args) + (apply #'magit-git-items "ls-files" "-z" "--full-name" args)) + +(defun magit-tracked-files (&rest args) + (magit-list-files "--cached" args)) + +(defun magit-untracked-files (&optional all files &rest args) + "Return a list of untracked files. + +Note that when using \"--directory\", the rules from \".gitignore\" +files from sub-directories are ignore, which is probably a Git bug. +See also `magit-list-untracked-files', which does not have this +issue." + (magit-list-files "--other" args + (and (not all) "--exclude-standard") + "--" files)) + +(defun magit-list-untracked-files (&optional files) + "Return a list of untracked files. + +List files if `magit-status-show-untracked-files' is non-nil, but also +take the local value of Git variable `status.showUntrackedFiles' into +account. The local value of the Lisp variable takes precedence over the +local value of the Git variable. The global value of the Git variable +is always ignored. + +See also `magit-untracked-files'." + (and-let* + ((value (or (and (local-variable-p 'magit-status-show-untracked-files) + magit-status-show-untracked-files) + (pcase (magit-get "--local" "status.showUntrackedFiles") + ((or "no" "off" "false" "0") 'no) + ((or "yes" "on" "true" "1") t) + ("all" 'all)) + magit-status-show-untracked-files)) + ((not (eq value 'no)))) + (mapcan (##and (eq (aref % 0) ??) + (list (substring % 3))) + (apply #'magit-git-items "status" "-z" "--porcelain" + (format "--untracked-files=%s" + (if (eq value 'all) "all" "normal")) + "--" files)))) + +(defun magit-ignored-files (&rest args) + (magit-list-files "--others" "--ignored" "--exclude-standard" args)) + +(defun magit-modified-files (&optional nomodules files) + (magit-git-items "diff-index" "-z" "--name-only" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + (magit-headish) "--" files)) + +(defun magit-unstaged-files (&optional nomodules files) + (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=u" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + "--" files)) + +(defun magit-staged-files (&optional nomodules files) + (magit-git-items "diff-index" "-z" "--name-only" "--cached" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + (if nomodules "--ignore-submodules" "--submodule=short") + (magit-headish) "--" files)) + +(defun magit-binary-files (&rest args) + (mapcan (##and (string-match "^-\t-\t\\(.+\\)" %) + (list (match-string 1 %))) + (apply #'magit-git-items + "diff" "-z" "--numstat" "--ignore-submodules" + args))) + +(defun magit-unmerged-files () + (magit-git-items "diff-files" "-z" "--name-only" "--diff-filter=U")) + +(defun magit-stashed-files (stash) + (magit-git-items "stash" "show" "-z" "--name-only" stash)) + +(defun magit-skip-worktree-files (&rest args) + (seq-keep (##and (= (aref % 0) ?S) + (substring % 2)) + (magit-list-files "-t" args))) + +(defun magit-assume-unchanged-files (&rest args) + (seq-keep (##and (memq (aref % 0) '(?h ?s ?m ?r ?c ?k)) + (substring % 2)) + (magit-list-files "-v" args))) + +(defun magit-revision-files (rev) + (magit-with-toplevel + (magit-git-items "ls-tree" "-z" "-r" "--name-only" rev))) + +(defun magit-revision-directories (rev) + "List directories that contain a tracked file in revision REV." + (magit-with-toplevel + (mapcar #'file-name-as-directory + (magit-git-items "ls-tree" "-z" "-r" "-d" "--name-only" rev)))) + +(defun magit-changed-files (rev-or-range &optional other-rev) + "Return list of files the have changed between two revisions. +If OTHER-REV is non-nil, REV-OR-RANGE should be a revision, not a +range. Otherwise, it can be any revision or range accepted by +\"git diff\" (i.e., , .., or ...)." + (magit-with-toplevel + (magit-git-items "diff" "-z" "--name-only" rev-or-range other-rev))) + +(defun magit-renamed-files (revA revB) + (mapcar (pcase-lambda (`(,_status ,fileA ,fileB)) + (cons fileA fileB)) + (seq-partition (magit-git-items "diff" "-z" "--name-status" + "--find-renames" + "--diff-filter=R" revA revB) + 3))) + +(defun magit--rev-file-name (file rev other-rev) + "For FILE, potentially renamed between REV and OTHER-REV, return name in REV. +Return nil, if FILE appears neither in REV nor OTHER-REV, +or if no rename is detected." + (or (car (member file (magit-revision-files rev))) + (and-let* ((renamed (magit-renamed-files rev other-rev))) + (car (rassoc file renamed))))) + +(defun magit-file-status (&rest args) + (magit--with-temp-process-buffer + (save-excursion (magit-git-insert "status" "-z" args)) + (let ((pos (point)) status) + (while (> (skip-chars-forward "[:print:]") 0) + (let ((x (char-after pos)) + (y (char-after (1+ pos))) + (file (buffer-substring (+ pos 3) (point)))) + (forward-char) + (if (memq x '(?R ?C)) + (progn + (setq pos (point)) + (skip-chars-forward "[:print:]") + (push (list file (buffer-substring pos (point)) x y) status) + (forward-char)) + (push (list file nil x y) status))) + (setq pos (point))) + status))) + +(defcustom magit-cygwin-mount-points + (and (eq system-type 'windows-nt) + (cl-sort (mapcar + (lambda (mount) + (if (string-match "^\\(.*\\) on \\(.*\\) type" mount) + (cons (file-name-as-directory (match-string 2 mount)) + (file-name-as-directory (match-string 1 mount))) + (lwarn '(magit) :error + "Failed to parse Cygwin mount: %S" mount))) + ;; If --exec-path is not a native Windows path, + ;; then we probably have a cygwin git. + (let ((process-environment + (append magit-git-environment + process-environment))) + (and (not (string-match-p + "\\`[a-zA-Z]:" + (car (process-lines + magit-git-executable "--exec-path")))) + (ignore-errors (process-lines "mount"))))) + #'> :key (pcase-lambda (`(,cyg . ,_win)) (length cyg)))) + "Alist of (CYGWIN . WIN32) directory names. +Sorted from longest to shortest CYGWIN name." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(alist :key-type string :value-type directory)) + +(defun magit-expand-git-file-name (filename) + (unless (file-name-absolute-p filename) + (setq filename (expand-file-name filename))) + (if-let ((cyg:win (and (not (file-remote-p default-directory)) ; see #4976 + (cl-assoc filename magit-cygwin-mount-points + :test (##string-prefix-p %2 %1))))) + (concat (cdr cyg:win) + (substring filename (length (car cyg:win)))) + filename)) + +(defun magit-convert-filename-for-git (filename) + "Convert FILENAME so that it can be passed to git. +1. If it is a absolute filename, then pass it through + `expand-file-name' to replace things such as \"~/\" that + Git does not understand. +2. If it is a remote filename, then remove the remote part. +3. Deal with an `windows-nt' Emacs vs. Cygwin Git incompatibility." + (if (file-name-absolute-p filename) + (if-let ((cyg:win (cl-rassoc filename magit-cygwin-mount-points + :test (##string-prefix-p %2 %1)))) + (concat (car cyg:win) + (substring filename (length (cdr cyg:win)))) + (let ((expanded (expand-file-name filename))) + (or (file-remote-p expanded 'localname) + expanded))) + filename)) + +(defun magit-decode-git-path (path) + (if (eq (aref path 0) ?\") + (decode-coding-string (read path) + (or magit-git-output-coding-system + (car default-process-coding-system)) + t) + path)) + +(defun magit-file-at-point (&optional expand assert) + (if-let ((file (magit-section-case + (file (oref it value)) + (hunk (magit-section-parent-value it))))) + (if expand + (expand-file-name file (magit-toplevel)) + file) + (when assert + (user-error "No file at point")))) + +(defun magit-current-file () + (or (magit-file-relative-name) + (magit-file-at-point) + (and (derived-mode-p 'magit-log-mode) + (car magit-buffer-log-files)))) + +;;; Predicates + +(defun magit-no-commit-p () + "Return t if there is no commit in the current Git repository." + (not (magit-rev-verify "HEAD"))) + +(defun magit-merge-commit-p (commit) + "Return t if COMMIT is a merge commit." + (length> (magit-commit-parents commit) 1)) + +(defun magit-anything-staged-p (&optional ignore-submodules &rest files) + "Return t if there are any staged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + ;; The "--submodule=short" is needed to work around a bug in Git v2.46.0 + ;; and v2.46.1. See #5212 and #5221. There are actually two related + ;; bugs, both of which are fixed in v2.46.2, with the following commits, + ;; but there is no workaround for the second bug. + ;; 11591850dd diff: report dirty submodules as changes in builtin_diff() + ;; 87cf96094a diff: report copies and renames as changes in run_diff_cmd() + (magit-git-failure "diff" "--quiet" "--cached" + (if ignore-submodules + "--ignore-submodules" + "--submodule=short") + "--" files)) + +(defun magit-anything-unstaged-p (&optional ignore-submodules &rest files) + "Return t if there are any unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (magit-git-failure "diff" "--quiet" + (if ignore-submodules + "--ignore-submodules" + ;; Work around a bug in Git v2.46.0. See #5212 and #5221. + "--submodule=short") + "--" files)) + +(defun magit-anything-modified-p (&optional ignore-submodules &rest files) + "Return t if there are any staged or unstaged changes. +If optional FILES is non-nil, then only changes to those files +are considered." + (or (apply #'magit-anything-staged-p ignore-submodules files) + (apply #'magit-anything-unstaged-p ignore-submodules files))) + +(defun magit-anything-unmerged-p (&rest files) + "Return t if there are any merge conflicts. +If optional FILES is non-nil, then only conflicts in those files +are considered." + (and (magit-git-string "ls-files" "--unmerged" files) t)) + +(defun magit-module-worktree-p (module) + (magit-with-toplevel + (file-exists-p (expand-file-name ".git" module)))) + +(defun magit-module-no-worktree-p (module) + (not (magit-module-worktree-p module))) + +(defun magit-ignore-submodules-p (&optional return-argument) + (or (cl-find-if (##string-prefix-p "--ignore-submodules" %) + magit-buffer-diff-args) + (and-let* ((value (magit-get "diff.ignoreSubmodules"))) + (if return-argument + (concat "--ignore-submodules=" value) + (concat "diff.ignoreSubmodules=" value))))) + +;;; Revisions and References + +(defun magit-rev-parse (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil." + (apply #'magit-git-string "rev-parse" args)) + +(defun magit-rev-parse-safe (&rest args) + "Execute `git rev-parse ARGS', returning first line of output. +If there is no output, return nil. Like `magit-rev-parse' but +ignore `magit-git-debug'." + (apply #'magit-git-str "rev-parse" args)) + +(defun magit-rev-parse-true (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +If it prints \"false\", then return nil. For any other output +signal an error." + (magit-git-true "rev-parse" args)) + +(defun magit-rev-parse-false (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"false\". +If it prints \"true\", then return nil. For any other output +signal an error." + (magit-git-false "rev-parse" args)) + +(defun magit-rev-parse-p (&rest args) + "Execute `git rev-parse ARGS', returning t if it prints \"true\". +Return t if the first (and usually only) output line is the +string \"true\", otherwise return nil." + (equal (magit-git-str "rev-parse" args) "true")) + +(defun magit-rev-verify (rev) + (magit-git-string-p "rev-parse" "--verify" rev)) + +(defun magit-commit-p (rev) + "Return full hash for REV if it names an existing commit." + (magit-rev-verify (magit--rev-dereference rev))) + +(defalias 'magit-rev-verify-commit #'magit-commit-p) + +(defalias 'magit-rev-hash #'magit-commit-p) + +(defun magit--rev-dereference (rev) + "Return a rev that forces Git to interpret REV as a commit. +If REV is nil or has the form \":/TEXT\", return REV itself." + (cond ((not rev) nil) + ((string-match-p "^:/" rev) rev) + ((concat rev "^{commit}")))) + +(defun magit-rev-equal (a b) + "Return t if there are no differences between the commits A and B." + (magit-git-success "diff" "--quiet" a b)) + +(defun magit-rev-eq (a b) + "Return t if A and B refer to the same commit." + (let ((a (magit-commit-p a)) + (b (magit-commit-p b))) + (and a b (equal a b)))) + +(defun magit-rev-ancestor-p (a b) + "Return non-nil if commit A is an ancestor of commit B." + (magit-git-success "merge-base" "--is-ancestor" a b)) + +(defun magit-rev-head-p (rev) + (or (equal rev "HEAD") + (and rev + (not (string-search ".." rev)) + (equal (magit-rev-parse rev) + (magit-rev-parse "HEAD"))))) + +(defun magit-rev-author-p (rev) + "Return t if the user is the author of REV. +More precisely return t if `user.name' is equal to the author +name of REV and/or `user.email' is equal to the author email +of REV." + (or (equal (magit-get "user.name") (magit-rev-format "%an" rev)) + (equal (magit-get "user.email") (magit-rev-format "%ae" rev)))) + +(defun magit-rev-name (rev &optional pattern not-anchored) + "Return a symbolic name for REV using `git-name-rev'. + +PATTERN can be used to limit the result to a matching ref. +Unless NOT-ANCHORED is non-nil, the beginning of the ref must +match PATTERN. + +An anchored lookup is done using the arguments +\"--exclude=*/ --exclude=*/HEAD\" in addition to +\"--refs=\", provided at least version v2.13 of Git is +used. Older versions did not support the \"--exclude\" argument. +When \"--exclude\" cannot be used and `git-name-rev' returns a +ref that should have been excluded, then that is discarded and +this function returns nil instead. This is unfortunate because +there might be other refs that do match. To fix that, update +Git." + (magit-git-string "name-rev" "--name-only" "--no-undefined" + (and pattern (concat "--refs=" pattern)) + (and pattern + (not not-anchored) + (list "--exclude=*/HEAD" + (concat "--exclude=*/" pattern))) + rev)) + +(defun magit-rev-branch (rev) + (and-let* ((name (magit-rev-name rev "refs/heads/*"))) + (and (not (string-match-p "[~^]" name)) name))) + +(defun magit-rev-fixup-target (rev) + (let ((msg (magit-rev-format "%s" rev))) + (save-match-data + (and (string-match "\\`\\(squash!\\|fixup!\\|amend!\\) \\(.+\\)" msg) + (magit-rev-format + "%h" (format "%s^{/^%s}" rev + (magit--ext-regexp-quote (match-string 2 msg)))))))) + +(defun magit-get-shortname (rev) + (let* ((fn (apply-partially #'magit-rev-name rev)) + (name (or (funcall fn "refs/tags/*") + (funcall fn "refs/heads/*") + (funcall fn "refs/remotes/*")))) + (cond ((not name) + (magit-rev-parse "--short" rev)) + ((string-match "^\\(?:tags\\|remotes\\)/\\(.+\\)" name) + (if (magit-ref-ambiguous-p (match-string 1 name)) + name + (match-string 1 name))) + ((magit-ref-maybe-qualify name))))) + +(defun magit-name-branch (rev &optional lax) + (or (magit-name-local-branch rev) + (magit-name-remote-branch rev) + (and lax (or (magit-name-local-branch rev t) + (magit-name-remote-branch rev t))))) + +(defun magit-name-local-branch (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/heads/*"))) + (and (or lax (not (string-match-p "[~^]" name))) name))) + +(defun magit-name-remote-branch (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/remotes/*"))) + (and (or lax (not (string-match-p "[~^]" name))) + (substring name 8)))) + +(defun magit-name-tag (rev &optional lax) + (and-let* ((name (magit-rev-name rev "refs/tags/*"))) + (progn + (when (string-suffix-p "^0" name) + (setq name (substring name 0 -2))) + (and (or lax (not (string-match-p "[~^]" name))) + (substring name 5))))) + +(defun magit-ref-abbrev (refname) + "Return an unambiguous abbreviation of REFNAME." + (magit-rev-parse "--verify" "--abbrev-ref" refname)) + +(defun magit-ref-fullname (refname) + "Return fully qualified refname for REFNAME. +If REFNAME is ambiguous, return nil." + (magit-rev-parse "--verify" "--symbolic-full-name" refname)) + +(defun magit-ref-ambiguous-p (refname) + (save-match-data + (if (string-match "\\`\\([^^~]+\\)\\(.*\\)" refname) + (not (magit-ref-fullname (match-string 1 refname))) + (error "%S has an unrecognized format" refname)))) + +(defun magit-ref-maybe-qualify (refname &optional prefix) + "If REFNAME is ambiguous, try to disambiguate it by prepend PREFIX to it. +Return an unambiguous refname, either REFNAME or that prefixed +with PREFIX, nil otherwise. If REFNAME has an offset suffix +such as \"~1\", then that is preserved. If optional PREFIX is +nil, then use \"heads/\"." + (if (magit-ref-ambiguous-p refname) + (let ((refname (concat (or prefix "heads/") refname))) + (and (not (magit-ref-ambiguous-p refname)) refname)) + refname)) + +(defun magit-ref-exists-p (ref) + (magit-git-success "show-ref" "--verify" ref)) + +(defun magit-ref-equal (a b) + "Return t if the refnames A and B are `equal'. +A symbolic-ref pointing to some ref, is `equal' to that ref, +as are two symbolic-refs pointing to the same ref. Refnames +may be abbreviated." + (let ((a (magit-ref-fullname a)) + (b (magit-ref-fullname b))) + (and a b (equal a b)))) + +(defun magit-ref-eq (a b) + "Return t if the refnames A and B are `eq'. +A symbolic-ref is `eq' to itself, but not to the ref it points +to, or to some other symbolic-ref that points to the same ref." + (let ((symbolic-a (magit-symbolic-ref-p a)) + (symbolic-b (magit-symbolic-ref-p b))) + (or (and symbolic-a + symbolic-b + (equal a b)) + (and (not symbolic-a) + (not symbolic-b) + (magit-ref-equal a b))))) + +(defun magit-headish () + "Return the `HEAD' or if that doesn't exist the hash of the empty tree." + (if (magit-no-commit-p) + (magit-git-string "mktree") + "HEAD")) + +(defun magit-branch-at-point () + (magit-section-case + (branch (oref it value)) + (commit (or (magit--painted-branch-at-point) + (magit-name-branch (oref it value)))) + (pullreq (and (fboundp 'forge--pullreq-branch) + (magit-branch-p + (forge--pullreq-branch (oref it value))))) + (related-refs (magit--painted-branch-at-point)) + ((unpulled unpushed) + (magit-ref-abbrev + (replace-regexp-in-string "\\.\\.\\.?" "" (oref it value)))))) + +(defun magit--painted-branch-at-point (&optional type) + (or (and (not (eq type 'remote)) + (memq (get-text-property (magit-point) 'font-lock-face) + (list 'magit-branch-local + 'magit-branch-current)) + (and-let* ((branch (magit-thing-at-point 'git-revision t))) + (cdr (magit-split-branch-name branch)))) + (and (not (eq type 'local)) + (memq (get-text-property (magit-point) 'font-lock-face) + (list 'magit-branch-remote + 'magit-branch-remote-head)) + (thing-at-point 'git-revision t)))) + +(defun magit-local-branch-at-point () + (magit-section-case + (branch (let ((branch (magit-ref-maybe-qualify (oref it value)))) + (when (member branch (magit-list-local-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'local) + (magit-name-local-branch (oref it value)))))) + +(defun magit-remote-branch-at-point () + (magit-section-case + (branch (let ((branch (oref it value))) + (when (member branch (magit-list-remote-branch-names)) + branch))) + (commit (or (magit--painted-branch-at-point 'remote) + (magit-name-remote-branch (oref it value)))))) + +(defun magit-commit-at-point () + (or (magit-section-value-if 'commit) + (magit-thing-at-point 'git-revision t) + (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk) + (magit-current-blame-chunk)))) + (oref chunk orig-rev)) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-branch-or-commit-at-point () + (or (magit-section-case + (branch (magit-ref-maybe-qualify (oref it value))) + (commit (or (magit--painted-branch-at-point) + (let ((rev (oref it value))) + (or (magit-name-branch rev) rev)))) + (tag (magit-ref-maybe-qualify (oref it value) "tags/")) + (pullreq (or (and (fboundp 'forge--pullreq-branch) + (magit-branch-p + (forge--pullreq-branch (oref it value)))) + (magit-ref-p (format "refs/pullreqs/%s" + (oref (oref it value) number))))) + ((unpulled unpushed) + (magit-ref-abbrev + (replace-regexp-in-string "\\.\\.\\.?" "" (oref it value))))) + (magit-thing-at-point 'git-revision t) + (and-let* ((chunk (and (bound-and-true-p magit-blame-mode) + (fboundp 'magit-current-blame-chunk) + (magit-current-blame-chunk)))) + (oref chunk orig-rev)) + (and magit-buffer-file-name + magit-buffer-refname) + (and (derived-mode-p 'magit-stash-mode + 'magit-merge-preview-mode + 'magit-revision-mode) + magit-buffer-revision))) + +(defun magit-tag-at-point () + (magit-section-case + (tag (oref it value)) + (commit (magit-name-tag (oref it value))))) + +(defun magit-stash-at-point () + (magit-section-value-if 'stash)) + +(defun magit-remote-at-point () + (magit-section-case + (remote (oref it value)) + ([branch remote] (magit-section-parent-value it)))) + +(defun magit-module-at-point (&optional predicate) + (when (magit-section-match 'module) + (let ((module (oref (magit-current-section) value))) + (and (or (not predicate) + (funcall predicate module)) + module)))) + +(defun magit-get-current-branch () + "Return the refname of the currently checked out branch. +Return nil if no branch is currently checked out." + (magit-git-string "symbolic-ref" "--short" "HEAD")) + +(defvar magit-get-previous-branch-timeout 0.5 + "Maximum time to spend in `magit-get-previous-branch'. +Given as a number of seconds.") + +(defun magit-get-previous-branch () + "Return the refname of the previously checked out branch. +Return nil if no branch can be found in the `HEAD' reflog +which is different from the current branch and still exists. +The amount of time spent searching is limited by +`magit-get-previous-branch-timeout'." + (let ((t0 (float-time)) + (current (magit-get-current-branch)) + (i 1) prev) + (while (if (> (- (float-time) t0) magit-get-previous-branch-timeout) + (setq prev nil) ;; Timed out. + (and (setq prev (magit-rev-verify (format "@{-%d}" i))) + (or (not (setq prev (magit-rev-branch prev))) + (equal prev current)))) + (cl-incf i)) + prev)) + +(defun magit--set-default-branch (newname oldname) + (let ((remote (or (magit-primary-remote) + (user-error "Cannot determine primary remote"))) + (branches (mapcar (##split-string % "\t") + (magit-git-lines + "for-each-ref" "refs/heads" + "--format=%(refname:short)\t%(upstream:short)")))) + (when-let ((old (assoc oldname branches)) + ((not (assoc newname branches)))) + (magit-call-git "branch" "-m" oldname newname) + (setcar old newname)) + (let ((new (if (magit-branch-p newname) + newname + (concat remote "/" newname)))) + (pcase-dolist (`(,branch ,upstream) branches) + (cond + ((equal upstream oldname) + (magit-set-upstream-branch branch new)) + ((equal upstream (concat remote "/" oldname)) + (magit-set-upstream-branch branch (concat remote "/" newname)))))))) + +(defun magit--get-default-branch (&optional update) + (let ((remote (magit-primary-remote))) + (when update + (if (not remote) + (user-error "Cannot determine primary remote") + (message "Determining default branch...") + (magit-git "fetch" "--prune") + (magit-git "remote" "set-head" "--auto" remote) + (message "Determining default branch...done"))) + (let ((branch (magit-git-string "symbolic-ref" "--short" + (format "refs/remotes/%s/HEAD" remote)))) + (when (and update (not branch)) + (error "Cannot determine new default branch")) + (list remote (and branch (cdr (magit-split-branch-name branch))))))) + +(defun magit-set-upstream-branch (branch upstream) + "Set UPSTREAM as the upstream of BRANCH. +If UPSTREAM is nil, then unset BRANCH's upstream. +Otherwise UPSTREAM has to be an existing branch." + (if upstream + (magit-call-git "branch" "--set-upstream-to" upstream branch) + (magit-call-git "branch" "--unset-upstream" branch))) + +(defun magit-get-upstream-ref (&optional branch) + "Return the upstream branch of BRANCH as a fully qualified ref. +It BRANCH is nil, then return the upstream of the current branch, +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e., return an existing local or +remote-tracking branch ref." + (and-let* ((branch (or branch (magit-get-current-branch)))) + (magit-ref-fullname (concat branch "@{upstream}")))) + +(defun magit-get-upstream-branch (&optional branch) + "Return the name of the upstream branch of BRANCH. +It BRANCH is nil, then return the upstream of the current branch +if any, nil otherwise. If the upstream is not configured, the +configured remote is an url, or the named branch does not exist, +then return nil. I.e., return the name of an existing local or +remote-tracking branch. The returned string is colorized +according to the branch type." + (magit--with-refresh-cache + (list default-directory 'magit-get-upstream-branch branch) + (and-let* ((branch (or branch (magit-get-current-branch))) + (upstream (magit-ref-abbrev (concat branch "@{upstream}")))) + (magit--propertize-face + upstream (if (equal (magit-get "branch" branch "remote") ".") + 'magit-branch-local + 'magit-branch-remote))))) + +(defun magit-get-local-upstream-branch (&optional branch) + (and-let* ((upstream (magit-get-upstream-branch branch)) + (upstream (cdr (magit-split-branch-name upstream)))) + (and (magit-branch-p upstream) upstream))) + +(defun magit-get-indirect-upstream-branch (branch &optional force) + (let ((remote (magit-get "branch" branch "remote"))) + (and remote (not (equal remote ".")) + ;; The user has opted in... + (or force + (seq-some (##if (magit-git-success "check-ref-format" "--branch" %) + (equal % branch) + (string-match-p % branch)) + magit-branch-prefer-remote-upstream)) + ;; and local BRANCH tracks a remote branch... + (let ((upstream (magit-get-upstream-branch branch))) + ;; whose upstream... + (and upstream + ;; has the same name as BRANCH... + (equal (substring upstream (1+ (length remote))) branch) + ;; and can be fast-forwarded to BRANCH. + (magit-rev-ancestor-p upstream branch) + upstream))))) + +(defun magit-get-upstream-remote (&optional branch allow-unnamed) + (and-let* ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote"))) + (and (not (equal remote ".")) + (cond ((member remote (magit-list-remotes)) + (magit--propertize-face remote 'magit-branch-remote)) + ((and allow-unnamed + (string-match-p "\\(\\`.\\{0,2\\}/\\|[:@]\\)" remote)) + (magit--propertize-face remote 'bold)))))) + +(defun magit-get-unnamed-upstream (&optional branch) + (and-let* ((branch (or branch (magit-get-current-branch))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (and (magit--unnamed-upstream-p remote merge) + (list (magit--propertize-face remote 'bold) + (magit--propertize-face merge 'magit-branch-remote))))) + +(defun magit--unnamed-upstream-p (remote merge) + (and remote (string-match-p "\\(\\`\\.\\{0,2\\}/\\|[:@]\\)" remote) + merge (string-prefix-p "refs/" merge))) + +(defun magit--valid-upstream-p (remote merge) + (and (or (equal remote ".") + (member remote (magit-list-remotes))) + (string-prefix-p "refs/" merge))) + +(defun magit-get-current-remote (&optional allow-unnamed) + (or (magit-get-upstream-remote nil allow-unnamed) + (and-let* ((remotes (magit-list-remotes)) + (remote (if (length= remotes 1) + (car remotes) + (magit-primary-remote)))) + (magit--propertize-face remote 'magit-branch-remote)))) + +(defun magit-get-push-remote (&optional branch) + (and-let* ((remote + (or (and (or branch (setq branch (magit-get-current-branch))) + (magit-get "branch" branch "pushRemote")) + (magit-get "remote.pushDefault")))) + (magit--propertize-face remote 'magit-branch-remote))) + +(defun magit-get-push-branch (&optional branch verify) + (magit--with-refresh-cache + (list default-directory 'magit-get-push-branch branch verify) + (and-let* ((branch (or branch (setq branch (magit-get-current-branch)))) + (remote (magit-get-push-remote branch)) + (target (concat remote "/" branch))) + (and (or (not verify) + (magit-rev-verify target)) + (magit--propertize-face target 'magit-branch-remote))))) + +(defun magit-get-@{push}-branch (&optional branch) + (let ((ref (magit-rev-parse "--symbolic-full-name" + (concat branch "@{push}")))) + (and ref + (string-prefix-p "refs/remotes/" ref) + (substring ref 13)))) + +(defun magit-get-remote (&optional branch) + (and (or branch (setq branch (magit-get-current-branch))) + (let ((remote (magit-get "branch" branch "remote"))) + (and (not (equal remote ".")) + remote)))) + +(defun magit-get-some-remote (&optional branch) + (or (magit-get-remote branch) + (and-let* ((main (magit-main-branch))) + (magit-get-remote main)) + (magit-primary-remote) + (car (magit-list-remotes)))) + +(defvar magit-primary-remote-names + '("upstream" "origin")) + +(defun magit-primary-remote () + "Return the primary remote. + +The primary remote is the remote that tracks the repository that +other repositories are forked from. It often is called \"origin\" +but because many people name their own fork \"origin\", using that +term would be ambiguous. Likewise we avoid the term \"upstream\" +because a branch's @{upstream} branch may be a local branch or a +branch from a remote other than the primary remote. + +If a remote exists whose name matches `magit.primaryRemote', then +that is considered the primary remote. If no remote by that name +exists, then remotes in `magit-primary-remote-names' are tried in +order and the first remote from that list that actually exists in +the current repository is considered its primary remote." + (let ((remotes (magit-list-remotes))) + (seq-find (##member % remotes) + (delete-dups + (delq nil + (cons (magit-get "magit.primaryRemote") + magit-primary-remote-names)))))) + +(defun magit-branch-merged-p (branch &optional target) + "Return non-nil if BRANCH is merged into its upstream and TARGET. + +TARGET defaults to the current branch. If `HEAD' is detached and +TARGET is nil, then always return nil. As a special case, if +TARGET is t, then return non-nil if BRANCH is merged into any one +of the other local branches. + +If, and only if, BRANCH has an upstream, then only return non-nil +if BRANCH is merged into both TARGET (as described above) as well +as into its upstream." + (and (if-let ((upstream (and (magit-branch-p branch) + (magit-get-upstream-branch branch)))) + (magit-rev-ancestor-p branch upstream) + t) + (if (eq target t) + (delete (magit-name-local-branch branch) + (magit-list-containing-branches branch)) + (and-let* ((target (or target (magit-get-current-branch)))) + (magit-rev-ancestor-p branch target))))) + +(defun magit-get-tracked (refname) + "Return the remote branch tracked by the remote-tracking branch REFNAME. +The returned value has the form (REMOTE . REF), where REMOTE is +the name of a remote and REF is the ref local to the remote." + (and-let* ((ref (magit-ref-fullname refname))) + (save-match-data + (seq-some (lambda (line) + (and (string-match "\ +\\`remote\\.\\([^.]+\\)\\.fetch=\\+?\\([^:]+\\):\\(.+\\)" line) + (let ((rmt (match-string 1 line)) + (src (match-string 2 line)) + (dst (match-string 3 line))) + (and (string-match (format "\\`%s\\'" + (string-replace + "*" "\\(.+\\)" dst)) + ref) + (cons rmt (string-replace + "*" (match-string 1 ref) src)))))) + (magit-git-lines "config" "--local" "--list"))))) + +(defun magit-split-branch-name (branch) + (cond ((member branch (magit-list-local-branch-names)) + (cons "." branch)) + ((string-match "/" branch) + (or (seq-some (lambda (remote) + (and (string-match + (format "\\`\\(%s\\)/\\(.+\\)\\'" remote) + branch) + (cons (match-string 1 branch) + (match-string 2 branch)))) + (magit-list-remotes)) + (error "Invalid branch name %s" branch))))) + +(defun magit-get-current-tag (&optional rev with-distance) + "Return the closest tag reachable from REV. + +If optional REV is nil, then default to `HEAD'. +If optional WITH-DISTANCE is non-nil then return (TAG COMMITS), +if it is `dirty' return (TAG COMMIT DIRTY). COMMITS is the number +of commits in `HEAD' but not in TAG and DIRTY is t if there are +uncommitted changes, nil otherwise." + (and-let* ((str (magit-git-str "describe" "--long" "--tags" + (and (eq with-distance 'dirty) "--dirty") + rev))) + (save-match-data + (string-match + "\\(.+\\)-\\(?:0[0-9]*\\|\\([0-9]+\\)\\)-g[0-9a-z]+\\(-dirty\\)?$" str) + (if with-distance + `(,(match-string 1 str) + ,(string-to-number (or (match-string 2 str) "0")) + ,@(and (match-string 3 str) (list t))) + (match-string 1 str))))) + +(defun magit-get-next-tag (&optional rev with-distance) + "Return the closest tag from which REV is reachable. + +If optional REV is nil, then default to `HEAD'. +If no such tag can be found or if the distance is 0 (in which +case it is the current tag, not the next), return nil instead. +If optional WITH-DISTANCE is non-nil, then return (TAG COMMITS) +where COMMITS is the number of commits in TAG but not in REV." + (and-let* ((str (magit-git-str "describe" "--contains" (or rev "HEAD")))) + (save-match-data + (when (string-match "^[^^~]+" str) + (setq str (match-string 0 str)) + (unless (equal str (magit-get-current-tag rev)) + (if with-distance + (list str (car (magit-rev-diff-count str rev))) + str)))))) + +(defun magit-list-refs (&optional namespaces format sortby) + "Return list of references, excluding symbolic references. + +When NAMESPACES is non-nil, list refs from these namespaces +rather than those from `magit-list-refs-namespaces'. + +FORMAT is passed to the `--format' flag of `git for-each-ref' +and defaults to \"%(refname)\". + +SORTBY is a key or list of keys to pass to the `--sort' flag of +`git for-each-ref'. When nil, use `magit-list-refs-sortby'" + (unless format + (setq format "%(refname)")) + (seq-keep (lambda (line) + (pcase-let* ((`(,symrefp ,value) + (split-string line " ")) + (symrefp (not (equal symrefp "")))) + (and (not symrefp) value))) + (magit-git-lines "for-each-ref" + (concat "--format=%(symref) " format) + (mapcar (##concat "--sort=" %) + (pcase (or sortby magit-list-refs-sortby) + ((and val (pred stringp)) (list val)) + ((and val (pred listp)) val))) + (or namespaces magit-list-refs-namespaces)))) + +(defun magit-list-branches () + (magit-list-refs (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branches () + (magit-list-refs "refs/heads")) + +(defun magit-list-remote-branches (&optional remote) + (magit-list-refs (concat "refs/remotes/" remote))) + +(defun magit-list-related-branches (relation &optional commit &rest args) + (seq-remove (##string-match-p "\\(\\`(HEAD\\|HEAD -> \\)" %) + (mapcar (##substring % 2) + (magit-git-lines "branch" args relation commit)))) + +(defun magit-list-containing-branches (&optional commit &rest args) + (magit-list-related-branches "--contains" commit args)) + +(defun magit-list-publishing-branches (&optional commit) + (seq-filter (##magit-rev-ancestor-p (or commit "HEAD") %) + magit-published-branches)) + +(defun magit-list-merged-branches (&optional commit &rest args) + (magit-list-related-branches "--merged" commit args)) + +(defun magit-list-unmerged-branches (&optional commit &rest args) + (magit-list-related-branches "--no-merged" commit args)) + +(defun magit-list-unmerged-to-upstream-branches () + (seq-filter (##and-let* ((upstream (magit-get-upstream-branch %))) + (member % (magit-list-unmerged-branches upstream))) + (magit-list-local-branch-names))) + +(defun magit-list-branches-pointing-at (commit) + (let ((re (format "\\`%s refs/\\(heads\\|remotes\\)/\\(.*\\)\\'" + (magit-rev-verify commit)))) + (seq-keep (##and (string-match re %) + (let ((name (match-string 2 %))) + (and (not (string-suffix-p "HEAD" name)) + name))) + (magit-git-lines "show-ref")))) + +(defun magit-list-refnames (&optional namespaces include-special) + (nconc (magit-list-refs namespaces "%(refname:short)") + (and include-special + (magit-list-special-refnames)))) + +(defvar magit-special-refnames + '("HEAD" "ORIG_HEAD" "FETCH_HEAD" "MERGE_HEAD" "CHERRY_PICK_HEAD")) + +(defun magit-list-special-refnames () + (let ((gitdir (magit-gitdir))) + (cl-remove-if-not (##file-exists-p (expand-file-name % gitdir)) + magit-special-refnames))) + +(defun magit-list-branch-names () + (magit-list-refnames (list "refs/heads" "refs/remotes"))) + +(defun magit-list-local-branch-names () + (magit-list-refnames "refs/heads")) + +(defun magit-list-remote-branch-names (&optional remote relative) + (if (and remote relative) + (let ((regexp (format "^refs/remotes/%s/\\(.+\\)" remote))) + (mapcan (##when (string-match regexp %) + (list (match-string 1 %))) + (magit-list-remote-branches remote))) + (magit-list-refnames (concat "refs/remotes/" remote)))) + +(defun magit-format-refs (format &rest args) + (let ((lines (magit-git-lines + "for-each-ref" (concat "--format=" format) + (or args (list "refs/heads" "refs/remotes" "refs/tags"))))) + (if (string-search "\f" format) + (mapcar (##split-string % "\f") lines) + lines))) + +(defun magit-list-remotes () + (magit-git-lines "remote")) + +(defun magit-list-tags () + (magit-git-lines "tag")) + +(defun magit-list-stashes (&optional format) + (magit-git-lines "stash" "list" (concat "--format=" (or format "%gd")))) + +(defun magit-list-active-notes-refs () + "Return notes refs according to `core.notesRef' and `notes.displayRef'." + (magit-git-lines "for-each-ref" "--format=%(refname)" + (or (magit-get "core.notesRef") "refs/notes/commits") + (magit-get-all "notes.displayRef"))) + +(defun magit-list-notes-refnames () + (mapcar (##substring % 6) (magit-list-refnames "refs/notes"))) + +(defun magit-remote-list-tags (remote) + (seq-keep (##and (not (string-suffix-p "^{}" %)) + (substring % 51)) + (magit-git-lines "ls-remote" "--tags" remote))) + +(defun magit-remote-list-branches (remote) + (seq-keep (##and (not (string-suffix-p "^{}" %)) + (substring % 52)) + (magit-git-lines "ls-remote" "--heads" remote))) + +(defun magit-remote-list-refs (remote) + (seq-keep (##and (not (string-suffix-p "^{}" %)) + (substring % 41)) + (magit-git-lines "ls-remote" remote))) + +(defun magit-remote-head (remote) + (and-let* ((line (cl-find-if + (##string-match + "\\`ref: refs/heads/\\([^\s\t]+\\)[\s\t]HEAD\\'" %) + (magit-git-lines "ls-remote" "--symref" remote "HEAD")))) + (match-string 1 line))) + +(defun magit-list-modified-modules () + (seq-keep (##and (string-match "\\`\\+\\([^ ]+\\) \\(.+\\) (.+)\\'" %) + (match-string 2 %)) + (magit-git-lines "submodule" "status"))) + +(defun magit-list-module-paths () + (magit-with-toplevel + (mapcan (##and (string-match "^160000 [0-9a-z]\\{40,\\} 0\t\\(.+\\)$" %) + (list (match-string 1 %))) + (magit-git-items "ls-files" "-z" "--stage")))) + +(defun magit-list-module-names () + (mapcar #'magit-get-submodule-name (magit-list-module-paths))) + +(defun magit-get-submodule-name (path) + "Return the name of the submodule at PATH. +PATH has to be relative to the super-repository." + (if (magit-git-version>= "2.38.0") + ;; "git submodule--helper name" was removed, + ;; but might still come back in another form. + (substring + (car (split-string + (car (or (magit-git-items + "config" "-z" + "-f" (expand-file-name ".gitmodules" (magit-toplevel)) + "--get-regexp" "^submodule\\..*\\.path$" + (concat "^" (regexp-quote (directory-file-name path)) "$")) + (error "No such submodule `%s'" path))) + "\n")) + 10 -5) + (magit-git-string "submodule--helper" "name" path))) + +(defun magit-list-worktrees () + "Return list of the worktrees of this repository. + +The returned list has the form (PATH COMMIT BRANCH BARE DETACHED +LOCKED PRUNABLE). The last four elements are booleans, with the +exception of LOCKED and PRUNABLE, which may also be strings. +See git-worktree(1) manpage for the meaning of the various parts. + +This function corrects a situation where \"git worktree list\" +would claim a worktree is bare, even though the working tree is +specified using `core.worktree'." + (let ((remote (file-remote-p default-directory)) + worktrees worktree) + (dolist (line (if (magit-git-version>= "2.36") + (magit-git-items "worktree" "list" "--porcelain" "-z") + (magit-git-lines "worktree" "list" "--porcelain"))) + (cond ((string-prefix-p "worktree" line) + (let ((path (substring line 9))) + (when remote + (setq path (concat remote path))) + ;; If the git directory is separate from the main + ;; worktree, then "git worktree" returns the git + ;; directory instead of the worktree, which isn't + ;; what it is supposed to do and not what we want. + ;; However, if the worktree has been removed, then + ;; we want to return it anyway; instead of nil. + (setq path (or (magit-toplevel path) path)) + (setq worktree (list path nil nil nil nil nil nil)) + (push worktree worktrees))) + ((string-prefix-p "HEAD" line) + (setf (nth 1 worktree) (substring line 5))) + ((string-prefix-p "branch" line) + (setf (nth 2 worktree) (substring line 18))) + ((string-equal line "bare") + (let* ((default-directory (car worktree)) + (wt (and (not (magit-get-boolean "core.bare")) + (magit-get "core.worktree")))) + (if (and wt (file-exists-p (expand-file-name wt))) + (progn (setf (nth 0 worktree) (expand-file-name wt)) + (setf (nth 2 worktree) (magit-rev-parse "HEAD")) + (setf (nth 3 worktree) (magit-get-current-branch))) + (setf (nth 3 worktree) t)))) + ((string-equal line "detached") + (setf (nth 4 worktree) t)) + ((string-prefix-p line "locked") + (setf (nth 5 worktree) + (if (> (length line) 6) (substring line 7) t))) + ((string-prefix-p line "prunable") + (setf (nth 6 worktree) + (if (> (length line) 8) (substring line 9) t))))) + (nreverse worktrees))) + +(defun magit-symbolic-ref-p (name) + (magit-git-success "symbolic-ref" "--quiet" name)) + +(defun magit-ref-p (rev) + (or (car (member rev (magit-list-refs "refs/"))) + (car (member rev (magit-list-refnames "refs/"))))) + +(defun magit-branch-p (rev) + (or (car (member rev (magit-list-branches))) + (car (member rev (magit-list-branch-names))))) + +(defun magit-local-branch-p (rev) + (or (car (member rev (magit-list-local-branches))) + (car (member rev (magit-list-local-branch-names))))) + +(defun magit-remote-branch-p (rev) + (or (car (member rev (magit-list-remote-branches))) + (car (member rev (magit-list-remote-branch-names))))) + +(defun magit-branch-set-face (branch) + (magit--propertize-face branch (if (magit-local-branch-p branch) + 'magit-branch-local + 'magit-branch-remote))) + +(defun magit-tag-p (rev) + (car (member rev (magit-list-tags)))) + +(defun magit-remote-p (string) + (car (member string (magit-list-remotes)))) + +(defvar magit-main-branch-names + '("main" "master" "trunk" "development") + "Branch names reserved for use by the primary branch. +Use function `magit-main-branch' to get the name actually used in +the current repository.") + +(defvar magit-long-lived-branches + (append magit-main-branch-names (list "maint" "next")) + "Branch names reserved for use by long lived branches.") + +(defun magit-main-branch () + "Return the main branch. + +If a branch exists whose name matches `init.defaultBranch', then +that is considered the main branch. If no branch by that name +exists, then the branch names in `magit-main-branch-names' are +tried in order. The first branch from that list that actually +exists in the current repository is considered its main branch." + (let ((branches (magit-list-local-branch-names))) + (seq-find (##member % branches) + (delete-dups + (delq nil + (cons (magit-get "init.defaultBranch") + magit-main-branch-names)))))) + +(defun magit-rev-diff-count (a b &optional first-parent) + "Return the commits in A but not B and vice versa. +Return a list of two integers: (A>B B>A). + +If `first-parent' is set, traverse only first parents." + (mapcar #'string-to-number + (split-string (magit-git-string "rev-list" + "--count" "--left-right" + (and first-parent "--first-parent") + (concat a "..." b)) + "\t"))) + +(defun magit-abbrev-length () + (let ((abbrev (magit-get "core.abbrev"))) + (if (and abbrev (not (equal abbrev "auto"))) + (string-to-number abbrev) + ;; Guess the length git will be using based on an example + ;; abbreviation. Actually HEAD's abbreviation might be an + ;; outlier, so use the shorter of the abbreviations for two + ;; commits. See #3034. + (if-let ((head (magit-rev-parse "--short" "HEAD")) + (head-len (length head))) + (min head-len + (if-let ((rev (magit-rev-parse "--short" "HEAD~"))) + (length rev) + head-len)) + ;; We're on an unborn branch, but perhaps the repository has + ;; other commits. See #4123. + (if-let ((commits (magit-git-lines "rev-list" "-n2" "--all" + "--abbrev-commit"))) + (apply #'min (mapcar #'length commits)) + ;; A commit does not exist. Fall back to the default of 7. + 7))))) + +(defun magit-abbrev-arg (&optional arg) + (format "--%s=%d" (or arg "abbrev") (magit-abbrev-length))) + +(defun magit-rev-abbrev (rev) + (magit-rev-parse (magit-abbrev-arg "short") rev)) + +(defun magit-commit-children (commit &optional args) + (seq-keep (lambda (line) + (pcase-let ((`(,child . ,parents) (split-string line " "))) + (and (member commit parents) child))) + (magit-git-lines "log" "--format=%H %P" + (or args (list "--branches" "--tags" "--remotes")) + "--not" commit))) + +(defun magit-commit-parents (commit) + (and-let* ((str (magit-git-string "rev-list" "-1" "--parents" commit))) + (cdr (split-string str)))) + +(defun magit-patch-id (rev) + (with-connection-local-variables + (magit--with-temp-process-buffer + (magit-process-file + shell-file-name nil '(t nil) nil shell-command-switch + (let ((exec (shell-quote-argument (magit-git-executable)))) + (format "%s diff-tree -u %s | %s patch-id" exec rev exec))) + (car (split-string (buffer-string)))))) + +(defun magit-rev-format (format &optional rev args) + ;; Prefer `git log --no-walk' to `git show --no-patch' because it + ;; performs better in some scenarios. + (let ((str (magit-git-string "log" "--no-walk" + (concat "--format=" format) args + (if rev (magit--rev-dereference rev) "HEAD") + "--"))) + (and (not (string-equal str "")) + str))) + +(defun magit-rev-insert-format (format &optional rev args) + ;; Prefer `git log --no-walk' to `git show --no-patch' because it + ;; performs better in some scenarios. + (magit-git-insert "log" "--no-walk" + (concat "--format=" format) args + (if rev (magit--rev-dereference rev) "HEAD") + "--")) + +(defun magit-format-rev-summary (rev) + (and-let* ((str (magit-rev-format "%h %s" rev))) + (progn + (magit--put-face 0 (string-match " " str) 'magit-hash str) + str))) + +(defvar magit-ref-namespaces + '(("\\`HEAD\\'" . magit-head) + ("\\`refs/tags/\\(.+\\)" . magit-tag) + ("\\`refs/heads/\\(.+\\)" . magit-branch-local) + ("\\`refs/remotes/\\(.+\\)" . magit-branch-remote) + ("\\`refs/bisect/\\(bad\\)" . magit-bisect-bad) + ("\\`refs/bisect/\\(skip.*\\)" . magit-bisect-skip) + ("\\`refs/bisect/\\(good.*\\)" . magit-bisect-good) + ("\\`refs/stash$" . magit-refname-stash) + ("\\`refs/wip/\\(.+\\)" . magit-refname-wip) + ("\\`refs/pullreqs/\\(.+\\)" . magit-refname-pullreq) + ("\\`\\(bad\\):" . magit-bisect-bad) + ("\\`\\(skip\\):" . magit-bisect-skip) + ("\\`\\(good\\):" . magit-bisect-good) + ("\\`\\(.+\\)" . magit-refname)) + "How refs are formatted for display. + +Each entry controls how a certain type of ref is displayed, and +has the form (REGEXP . FACE). REGEXP is a regular expression +used to match full refs. The first entry whose REGEXP matches +the reference is used. + +In log and revision buffers the first regexp submatch becomes the +\"label\" that represents the ref and is propertized with FONT. +In refs buffers the displayed text is controlled by other means +and this option only controls what face is used.") + +(defun magit-format-ref-labels (string) + (save-match-data + (let ((refs (split-string + (replace-regexp-in-string "\\(tag: \\|HEAD -> \\)" "" string) + ", " t)) + state head upstream tags branches remotes other combined) + (dolist (ref refs) + (let* ((face (cdr (seq-find (##string-match (car %) ref) + magit-ref-namespaces))) + (name (match-string 1 ref)) + (name (if (and name + (not (string-prefix-p "refs/tags/" ref)) + (magit-rev-verify (concat "refs/tags/" name))) + (magit-ref-abbrev ref) + (or name ref))) + (name (magit--propertize-face name face))) + (cl-case face + ((magit-bisect-bad magit-bisect-skip magit-bisect-good) + (setq state name)) + (magit-head + (setq head (magit--propertize-face "@" 'magit-head))) + (magit-tag (push name tags)) + (magit-branch-local (push name branches)) + (magit-branch-remote (push name remotes)) + (t (push name other))))) + (setq remotes + (seq-keep + (lambda (name) + (if (string-match "\\`\\([^/]*\\)/\\(.*\\)\\'" name) + (let ((r (match-string 1 name)) + (b (match-string 2 name))) + (and (not (equal b "HEAD")) + (if (equal (concat "refs/remotes/" name) + (magit-git-string + "symbolic-ref" + (format "refs/remotes/%s/HEAD" r))) + (magit--propertize-face + name 'magit-branch-remote-head) + name))) + name)) + remotes)) + (let* ((current (magit-get-current-branch)) + (target (magit-get-upstream-branch current))) + (dolist (name branches) + (let ((push (car (member (magit-get-push-branch name) remotes)))) + (when push + (setq remotes (delete push remotes)) + (string-match "^[^/]*/" push) + (setq push (substring push 0 (match-end 0)))) + (cond + ((equal name current) + (setq head + (concat push + (magit--propertize-face + name 'magit-branch-current)))) + ((equal name target) + (setq upstream + (concat push + (magit--propertize-face + name '(magit-branch-upstream + magit-branch-local))))) + (t + (push (concat push name) combined))))) + (when (and target (not upstream)) + (if (member target remotes) + (progn + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq remotes (delete target remotes))) + (when-let ((target (car (member target combined)))) + (magit--add-face-text-property + 0 (length target) 'magit-branch-upstream nil target) + (setq upstream target) + (setq combined (delete target combined)))))) + (string-join (flatten-tree `(,state + ,head + ,upstream + ,@(nreverse tags) + ,@(nreverse combined) + ,@(nreverse remotes) + ,@other)) + " ")))) + +(defun magit-object-type (object) + (magit-git-string "cat-file" "-t" object)) + +(defmacro magit-with-blob (commit file &rest body) + (declare (indent 2) + (debug (form form body))) + `(magit--with-temp-process-buffer + (let ((buffer-file-name ,file)) + (save-excursion + (magit-git-insert "cat-file" "-p" + (concat ,commit ":" buffer-file-name))) + (decode-coding-inserted-region + (point-min) (point-max) buffer-file-name t nil nil t) + ,@body))) + +(defmacro magit-with-temp-index (tree arg &rest body) + (declare (indent 2) (debug (form form body))) + (let ((file (gensym "file"))) + `(let ((magit--refresh-cache nil) + (,file (magit-convert-filename-for-git + (make-temp-name + (expand-file-name "index.magit." (magit-gitdir)))))) + (unwind-protect + (magit-with-toplevel + (when-let* ((tree ,tree) + ((not (magit-git-success + "read-tree" ,arg tree + (concat "--index-output=" ,file))))) + (error "Cannot read tree %s" tree)) + (with-environment-variables (("GIT_INDEX_FILE" ,file)) + ,@body)) + (ignore-errors + (delete-file (concat (file-remote-p default-directory) ,file))))))) + +(defun magit-commit-tree (message &optional tree &rest parents) + (magit-git-string "commit-tree" "--no-gpg-sign" "-m" message + (mapcan (##list "-p" %) (delq nil parents)) + (or tree + (magit-git-string "write-tree") + (error "Cannot write tree")))) + +(defun magit-commit-worktree (message &optional arg &rest other-parents) + (magit-with-temp-index "HEAD" arg + (and (magit-update-files (magit-unstaged-files)) + (apply #'magit-commit-tree message nil "HEAD" other-parents)))) + +(defun magit-update-files (files) + (magit-git-success "update-index" "--add" "--remove" "--" files)) + +(defun magit-update-ref (ref message rev) + (let ((magit--refresh-cache nil)) + (unless (zerop (magit-call-git "update-ref" "--create-reflog" + "-m" message ref rev + (or (magit-rev-verify ref) ""))) + (error "Cannot update %s with %s" ref rev)))) + +(defconst magit-range-re + (concat "\\`\\([^ \t]*[^.]\\)?" ; revA + "\\(\\.\\.\\.?\\)" ; range marker + "\\([^.][^ \t]*\\)?\\'")) ; revB + +(defun magit-split-range (range) + (pcase-let ((`(,beg ,end ,sep) (magit--split-range-raw range))) + (and sep + (let ((beg (or beg "HEAD")) + (end (or end "HEAD"))) + (if (string-equal (match-string 2 range) "...") + (and-let* ((base (magit-git-string "merge-base" beg end))) + (cons base end)) + (cons beg end)))))) + +(defun magit--split-range-raw (range) + (and (string-match magit-range-re range) + (let ((beg (match-string 1 range)) + (end (match-string 3 range))) + (and (or beg end) + (list beg end (match-string 2 range)))))) + +(defun magit-hash-range (range) + (if (string-match magit-range-re range) + (let ((beg (match-string 1 range)) + (end (match-string 3 range))) + (and (or beg end) + (let ((beg-hash (and beg (magit-rev-hash (match-string 1 range)))) + (end-hash (and end (magit-rev-hash (match-string 3 range))))) + (and (or (not beg) beg-hash) + (or (not end) end-hash) + (concat beg-hash (match-string 2 range) end-hash))))) + (magit-rev-hash range))) + +(defvar magit-revision-faces + '(magit-hash + magit-tag + magit-branch-remote + magit-branch-remote-head + magit-branch-local + magit-branch-current + magit-branch-upstream + magit-branch-warning + magit-head + magit-refname + magit-refname-stash + magit-refname-wip + magit-refname-pullreq)) + +(put 'git-revision 'thing-at-point #'magit-thingatpt--git-revision) +(defun magit-thingatpt--git-revision (&optional disallow) + ;; Support hashes and references. + (and-let* ((bounds + (let ((c (concat "\s\n\t~^:?*[\\" disallow))) + (cl-letf + (((get 'git-revision 'beginning-op) + (lambda () + (if (re-search-backward (format "[%s]" c) nil t) + (forward-char) + (goto-char (point-min))))) + ((get 'git-revision 'end-op) + (lambda () + (re-search-forward (format "\\=[^%s]*" c) nil t)))) + (bounds-of-thing-at-point 'git-revision)))) + (string (buffer-substring-no-properties (car bounds) (cdr bounds))) + ;; References are allowed to contain most parentheses and + ;; most punctuation, but if those characters appear at the + ;; edges of a possible reference in arbitrary text, then + ;; they are much more likely to be intended as just that: + ;; punctuation and delimiters. + (string (thread-first string + (string-trim-left "[(/.,;!]")))) + (let (disallow) + (when (or (string-match-p "\\.\\." string) + (string-match-p "/\\." string)) + (setq disallow (concat disallow "."))) + (when (string-match-p "@{" string) + (setq disallow (concat disallow "@{"))) + (if disallow + ;; These additional restrictions overcompensate, + ;; but that only matters in rare cases. + (magit-thingatpt--git-revision disallow) + (and (not (equal string "@")) + (or (and (>= (length string) 7) + (string-match-p "[a-z]" string) + (magit-commit-p string)) + (and (magit-ref-p string) + (member (get-text-property (point) 'face) + magit-revision-faces))) + string))))) + +(put 'git-revision-range 'thing-at-point #'magit-thingatpt--git-revision-range) +(defun magit-thingatpt--git-revision-range () + ;; Support hashes but no references. + (and-let* ((bounds + (cl-letf (((get 'git-revision 'beginning-op) + (lambda () + (if (re-search-backward "[^a-z0-9.]" nil t) + (forward-char) + (goto-char (point-min))))) + ((get 'git-revision 'end-op) + (lambda () + (and (re-search-forward "[^a-z0-9.]" nil t) + (backward-char))))) + (bounds-of-thing-at-point 'git-revision))) + (range (buffer-substring-no-properties (car bounds) (cdr bounds)))) + ;; Validate but return as-is. + (and (magit-hash-range range) range))) + +;;; Completion + +(defvar magit-revision-history nil) + +(defun magit--minibuf-default-add-commit () + (let ((fn minibuffer-default-add-function)) + (setq-local + minibuffer-default-add-function + (lambda () + (let ((rest (and (functionp fn) (funcall fn)))) + (if-let ((commit (with-selected-window (minibuffer-selected-window) + (or (magit-thing-at-point 'git-revision-range t) + (magit-commit-at-point))))) + (let ((rest (cons commit (delete commit rest))) + (def minibuffer-default)) + (if (listp def) + (append def rest) + (cons def (delete def rest)))) + rest)))))) + +(defun magit-read-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-branch-or-commit (prompt &optional secondary-default exclude) + (let ((current (magit-get-current-branch)) + (branch-at-point (magit-branch-at-point)) + (commit-at-point (magit-commit-at-point)) + (choices (delete exclude (magit-list-refnames nil t)))) + (when (equal current exclude) + (setq current nil)) + (when (equal branch-at-point exclude) + (setq branch-at-point nil)) + (when (and commit-at-point (not branch-at-point)) + (setq choices (cons commit-at-point choices))) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read + prompt choices nil nil nil 'magit-revision-history + (or branch-at-point commit-at-point secondary-default current)) + (user-error "Nothing selected"))))) + +(defun magit-read-range-or-commit (prompt &optional secondary-default) + (magit-read-range + prompt + (or (and-let* ((revs (magit-region-values '(commit branch) t))) + (progn + (deactivate-mark) + (concat (car (last revs)) ".." (car revs)))) + (magit-branch-or-commit-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-range (prompt &optional default) + (minibuffer-with-setup-hook + (lambda () + (magit--minibuf-default-add-commit) + (setq-local crm-separator "\\.\\.\\.?")) + (magit-completing-read-multiple + (concat prompt ": ") + (magit-list-refnames) + nil nil nil 'magit-revision-history default nil t))) + +(defun magit-read-remote-branch + (prompt &optional remote default local-branch require-match) + (let ((choice (magit-completing-read + prompt + (cl-union (and local-branch + (if remote + (list local-branch) + (mapcar (##concat % "/" local-branch) + (magit-list-remotes)))) + (magit-list-remote-branch-names remote t) + :test #'equal) + nil require-match nil 'magit-revision-history default))) + (if (or remote (string-match "\\`\\([^/]+\\)/\\(.+\\)" choice)) + choice + (user-error "`%s' doesn't have the form REMOTE/BRANCH" choice)))) + +(defun magit-read-refspec (prompt remote) + (magit-completing-read prompt + (prog2 (message "Determining available refs...") + (magit-remote-list-refs remote) + (message "Determining available refs...done")))) + +(defun magit-read-local-branch (prompt &optional secondary-default) + (magit-completing-read prompt (magit-list-local-branch-names) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-local-branch-or-commit (prompt) + (let ((choices (nconc (magit-list-local-branch-names) + (magit-list-special-refnames))) + (commit (magit-commit-at-point))) + (when commit + (push commit choices)) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read prompt choices + nil nil nil 'magit-revision-history + (or (magit-local-branch-at-point) commit)) + (user-error "Nothing selected"))))) + +(defun magit-read-local-branch-or-ref (prompt &optional secondary-default) + (magit-completing-read prompt (nconc (magit-list-local-branch-names) + (magit-list-refs "refs/")) + nil t nil 'magit-revision-history + (or (magit-local-branch-at-point) + secondary-default + (magit-get-current-branch)))) + +(defun magit-read-other-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt (delete exclude (magit-list-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-other-branch-or-commit + (prompt &optional exclude secondary-default) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-branch-or-commit-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) + (not (and (not current) + (magit-rev-equal atpoint "HEAD"))) + atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (minibuffer-with-setup-hook #'magit--minibuf-default-add-commit + (or (magit-completing-read prompt (delete exclude (magit-list-refnames)) + nil nil nil 'magit-revision-history default) + (user-error "Nothing selected"))))) + +(defun magit-read-other-local-branch + (prompt &optional exclude secondary-default no-require-match) + (let* ((current (magit-get-current-branch)) + (atpoint (magit-local-branch-at-point)) + (exclude (or exclude current)) + (default (or (and (not (equal atpoint exclude)) atpoint) + (and (not (equal current exclude)) current) + secondary-default + (magit-get-previous-branch)))) + (magit-completing-read prompt + (delete exclude (magit-list-local-branch-names)) + nil (not no-require-match) + nil 'magit-revision-history default))) + +(defun magit-read-branch-prefer-other (prompt) + (let* ((current (magit-get-current-branch)) + (commit (magit-commit-at-point)) + (atrev (and commit (magit-list-branches-pointing-at commit))) + (atpoint (magit--painted-branch-at-point))) + (magit-completing-read prompt (magit-list-branch-names) + nil t nil 'magit-revision-history + (or (magit-section-value-if 'branch) + atpoint + (and (not (cdr atrev)) (car atrev)) + (seq-find (##not (equal % current)) atrev) + (magit-get-previous-branch) + (car atrev))))) + +(defun magit-read-upstream-branch (&optional branch prompt) + "Read the upstream for BRANCH using PROMPT. +If optional BRANCH is nil, then read the upstream for the +current branch, or raise an error if no branch is checked +out. Only existing branches can be selected." + (unless branch + (setq branch (or (magit-get-current-branch) + (error "Need a branch to set its upstream")))) + (let ((branches (delete branch (magit-list-branch-names)))) + (magit-completing-read + (or prompt (format "Change upstream of %s to" branch)) + branches nil t nil 'magit-revision-history + (or (let ((r (car (member (magit-remote-branch-at-point) branches))) + (l (car (member (magit-local-branch-at-point) branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (and-let* ((main (magit-main-branch))) + (let ((r (car (member (concat "origin/" main) branches))) + (l (car (member main branches)))) + (if magit-prefer-remote-upstream (or r l) (or l r)))) + (car (member (magit-get-previous-branch) branches)))))) + +(defun magit-read-starting-point (prompt &optional branch default) + (or (magit-completing-read + (concat prompt + (and branch + (if (bound-and-true-p ivy-mode) + ;; Ivy-mode strips faces from prompt. + (format " `%s'" branch) + (concat " " (magit--propertize-face + branch 'magit-branch-local)))) + " starting at") + (nconc (list "HEAD") + (magit-list-refnames) + (directory-files (magit-gitdir) nil "_HEAD\\'")) + nil nil nil 'magit-revision-history + (or default (magit--default-starting-point))) + (user-error "Nothing selected"))) + +(defun magit--default-starting-point () + (or (let ((r (magit-remote-branch-at-point)) + (l (magit-local-branch-at-point))) + (if magit-prefer-remote-upstream (or r l) (or l r))) + (magit-commit-at-point) + (magit-stash-at-point) + (magit-get-current-branch))) + +(defun magit-read-tag (prompt &optional require-match) + (magit-completing-read prompt (magit-list-tags) nil + require-match nil 'magit-revision-history + (magit-tag-at-point))) + +(defun magit-read-stash (prompt) + (let* ((atpoint (magit-stash-at-point)) + (default (and atpoint + (concat atpoint (magit-rev-format " %s" atpoint)))) + (choices (mapcar (lambda (c) + (pcase-let ((`(,rev ,msg) (split-string c "\0"))) + (concat (propertize rev 'face 'magit-hash) + " " msg))) + (magit-list-stashes "%gd%x00%s"))) + (choice (magit-completing-read prompt choices + nil t nil nil + default + (car choices)))) + (and choice + (string-match "^\\([^ ]+\\) \\(.+\\)" choice) + (substring-no-properties (match-string 1 choice))))) + +(defun magit-read-remote (prompt &optional default use-only) + (let ((remotes (magit-list-remotes))) + (if (and use-only (length= remotes 1)) + (car remotes) + (magit-completing-read prompt remotes + nil t nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))))) + +(defun magit-read-remote-or-url (prompt &optional default) + (magit-completing-read prompt + (nconc (magit-list-remotes) + (list "https://" "git://" "git@")) + nil nil nil nil + (or default + (magit-remote-at-point) + (magit-get-remote)))) + +(defun magit-read-module-path (prompt &optional predicate) + (magit-completing-read prompt (magit-list-module-paths) + predicate t nil nil + (magit-module-at-point predicate))) + +(defun magit-module-confirm (verb &optional predicate) + ;; Some predicates use the inefficient `magit-toplevel' + ;; and some repositories have thousands of submodules. + (let ((magit--refresh-cache (list (cons 0 0))) + (modules nil)) + (if current-prefix-arg + (progn + (setq modules (magit-list-module-paths)) + (when predicate + (setq modules (seq-filter predicate modules))) + (unless modules + (if predicate + (user-error "No modules satisfying %s available" predicate) + (user-error "No modules available")))) + (setq modules (magit-region-values 'module)) + (when modules + (when predicate + (setq modules (seq-filter predicate modules))) + (unless modules + (user-error "No modules satisfying %s selected" predicate)))) + (if (or (length> modules 1) current-prefix-arg) + (magit-confirm t nil (format "%s %%d modules" verb) nil modules) + (list (magit-read-module-path (format "%s module" verb) predicate))))) + +;;; _ +(provide 'magit-git) +;;; magit-git.el ends here blob - /dev/null blob + 0ee63df0e210cbc67456aaa55cb566fd5611627f (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-gitignore.el @@ -0,0 +1,195 @@ +;;; magit-gitignore.el --- Intentionally untracked files -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements gitignore commands. + +;;; Code: + +(require 'magit) + +;;; Transient + +;;;###autoload (autoload 'magit-gitignore "magit-gitignore" nil t) +(transient-define-prefix magit-gitignore () + "Instruct Git to ignore a file or pattern." + :man-page "gitignore" + ["Gitignore" + ("t" "shared at toplevel (.gitignore)" + magit-gitignore-in-topdir) + ("s" "shared in subdirectory (path/to/.gitignore)" + magit-gitignore-in-subdir) + ("p" "privately (.git/info/exclude)" + magit-gitignore-in-gitdir) + ("g" magit-gitignore-on-system + :if (##magit-get "core.excludesfile") + :description (##format "privately for all repositories (%s)" + (magit-get "core.excludesfile")))] + ["Skip worktree" + (7 "w" "do skip worktree" magit-skip-worktree) + (7 "W" "do not skip worktree" magit-no-skip-worktree)] + ["Assume unchanged" + (7 "u" "do assume unchanged" magit-assume-unchanged) + (7 "U" "do not assume unchanged" magit-no-assume-unchanged)]) + +;;; Gitignore Commands + +;;;###autoload +(defun magit-gitignore-in-topdir (rule) + "Add the Git ignore RULE to the top-level \".gitignore\" file. +Since this file is tracked, it is shared with other clones of the +repository. Also stage the file." + (interactive (list (magit-gitignore-read-pattern))) + (magit-with-toplevel + (magit--gitignore rule ".gitignore") + (magit-run-git "add" ".gitignore"))) + +;;;###autoload +(defun magit-gitignore-in-subdir (rule directory) + "Add the Git ignore RULE to a \".gitignore\" file in DIRECTORY. +Prompt the user for a directory and add the rule to the +\".gitignore\" file in that directory. Since such files are +tracked, they are shared with other clones of the repository. +Also stage the file." + (interactive (list (magit-gitignore-read-pattern) + (read-directory-name "Limit rule to files in: "))) + (magit-with-toplevel + (let ((file (expand-file-name ".gitignore" directory))) + (magit--gitignore rule file) + (magit-run-git "add" (magit-convert-filename-for-git file))))) + +;;;###autoload +(defun magit-gitignore-in-gitdir (rule) + "Add the Git ignore RULE to \"$GIT_DIR/info/exclude\". +Rules in that file only affects this clone of the repository." + (interactive (list (magit-gitignore-read-pattern))) + (magit--gitignore rule (expand-file-name "info/exclude" (magit-gitdir))) + (magit-refresh)) + +;;;###autoload +(defun magit-gitignore-on-system (rule) + "Add the Git ignore RULE to the file specified by `core.excludesFile'. +Rules that are defined in that file affect all local repositories." + (interactive (list (magit-gitignore-read-pattern))) + (magit--gitignore rule + (or (magit-get "core.excludesFile") + (error "Variable `core.excludesFile' isn't set"))) + (magit-refresh)) + +(defun magit--gitignore (rule file) + (when-let ((directory (file-name-directory file))) + (make-directory directory t)) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (replace-regexp-in-string "\\(\\\\*\\)" "\\1\\1" rule)) + (insert "\n") + (write-region nil nil file))) + +(defun magit-gitignore-read-pattern () + (let* ((default (magit-current-file)) + (base (car magit-buffer-diff-files)) + (base (and base (file-directory-p base) base)) + (choices + (delete-dups + (mapcan + (lambda (file) + (cons (concat "/" file) + (and-let* ((ext (file-name-extension file))) + (list (concat "/" (file-name-directory file) "*." ext) + (concat "*." ext))))) + (sort (nconc + (magit-untracked-files nil base) + ;; The untracked section of the status buffer lists + ;; directories containing only untracked files. + ;; Add those as candidates. + (seq-filter #'directory-name-p + (magit-list-files + "--other" "--exclude-standard" "--directory" + "--no-empty-directory" "--" base))) + #'string-lessp))))) + (when default + (setq default (concat "/" default)) + (unless (member default choices) + (setq default (concat "*." (file-name-extension default))) + (unless (member default choices) + (setq default nil)))) + (magit-completing-read "File or pattern to ignore" + choices nil nil nil nil default))) + +;;; Skip Worktree Commands + +;;;###autoload +(defun magit-skip-worktree (file) + "Call \"git update-index --skip-worktree -- FILE\"." + (interactive + (list (magit-read-file-choice "Skip worktree for" + (magit-with-toplevel + (cl-set-difference + (magit-list-files) + (magit-skip-worktree-files) + :test #'equal))))) + (magit-with-toplevel + (magit-run-git "update-index" "--skip-worktree" "--" file))) + +;;;###autoload +(defun magit-no-skip-worktree (file) + "Call \"git update-index --no-skip-worktree -- FILE\"." + (interactive + (list (magit-read-file-choice "Do not skip worktree for" + (magit-with-toplevel + (magit-skip-worktree-files))))) + (magit-with-toplevel + (magit-run-git "update-index" "--no-skip-worktree" "--" file))) + +;;; Assume Unchanged Commands + +;;;###autoload +(defun magit-assume-unchanged (file) + "Call \"git update-index --assume-unchanged -- FILE\"." + (interactive + (list (magit-read-file-choice "Assume file to be unchanged" + (magit-with-toplevel + (cl-set-difference + (magit-list-files) + (magit-assume-unchanged-files) + :test #'equal))))) + (magit-with-toplevel + (magit-run-git "update-index" "--assume-unchanged" "--" file))) + +;;;###autoload +(defun magit-no-assume-unchanged (file) + "Call \"git update-index --no-assume-unchanged -- FILE\"." + (interactive + (list (magit-read-file-choice "Do not assume file to be unchanged" + (magit-with-toplevel + (magit-assume-unchanged-files))))) + (magit-with-toplevel + (magit-run-git "update-index" "--no-assume-unchanged" "--" file))) + +;;; _ +(provide 'magit-gitignore) +;;; magit-gitignore.el ends here blob - /dev/null blob + eaff50bd0827ab28e8f935c8862c13e850b84ace (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-log.el @@ -0,0 +1,2053 @@ +;;; magit-log.el --- Inspect Git history -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for looking at Git logs, including +;; special logs like cherry-logs, as well as for selecting a commit +;; from a log. + +;;; Code: + +(require 'magit-core) +(require 'magit-diff) + +(declare-function magit--any-wip-mode-enabled-p "magit-wip" ()) +(declare-function magit-blob-visit "magit-files" (blob-or-file)) +(declare-function magit-cherry-apply "magit-sequence" (commit &optional args)) +(declare-function magit-insert-head-branch-header "magit-status" + (&optional branch)) +(declare-function magit-insert-upstream-branch-header "magit-status" + (&optional branch pull keyword)) +(declare-function magit-read-file-from-rev "magit-files" + (rev prompt &optional default include-dirs)) +(declare-function magit-rebase--get-state-lines "magit-sequence" + (file)) +(declare-function magit-show-commit "magit-diff" + (arg1 &optional arg2 arg3 arg4)) +(declare-function magit-reflog-format-subject "magit-reflog" (subject)) +(defvar magit-refs-focus-column-width) +(defvar magit-refs-margin) +(defvar magit-refs-show-commit-count) +(defvar magit-buffer-margin) +(defvar magit-status-margin) +(defvar magit-status-sections-hook) + +(require 'ansi-color) +(require 'crm) +(require 'which-func) + +(make-obsolete-variable 'magit-log-highlight-keywords + 'magit-log-wash-summary-hook + "Magit 4.3.0") + +(make-obsolete-variable 'magit-log-format-message-function + 'magit-log-wash-summary-hook + "Magit 4.3.0") + +;;; Options +;;;; Log Mode + +(defgroup magit-log nil + "Inspect and manipulate Git history." + :link '(info-link "(magit)Logging") + :group 'magit-commands + :group 'magit-modes) + +(defcustom magit-log-mode-hook nil + "Hook run after entering Magit-Log mode." + :group 'magit-log + :type 'hook) + +(defcustom magit-log-remove-graph-args '("--follow" "-G" "-S" "-L") + "The log arguments that cause the `--graph' argument to be dropped. + +The default value lists the arguments that are incompatible with +`--graph' and therefore must be dropped when that is used. You +can add additional arguments that are available in `magit-log', +but I recommend that you don't do that. Nowadays I would define +this as a constant, but I am preserving it as an option, in case +someone actually customized it." + :package-version '(magit . "4.3.7") + :group 'magit-log + :type '(repeat (string :tag "Argument")) + :options '("--follow" "-G" "-S" "-L")) + +(defcustom magit-log-revision-headers-format "\ +%+b%+N +Author: %aN <%aE> +Committer: %cN <%cE>" + "Additional format string used with the `++header' argument." + :package-version '(magit . "3.2.0") + :group 'magit-log + :type 'string) + +(defcustom magit-log-auto-more nil + "Insert more log entries automatically when moving past the last entry. +Only considered when moving past the last entry with +`magit-goto-*-section' commands." + :group 'magit-log + :type 'boolean) + +(defcustom magit-log-margin '(t age magit-log-margin-width t 18) + "Format of the margin in `magit-log-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set (apply-partially #'magit-margin-set-variable 'magit-log-mode)) + +(defcustom magit-log-margin-show-committer-date nil + "Whether to show the committer date in the margin. + +This option only controls whether the committer date is displayed +instead of the author date. Whether some date is displayed in +the margin and whether the margin is displayed at all is +controlled by other options." + :package-version '(magit . "3.0.0") + :group 'magit-log + :group 'magit-margin + :type 'boolean) + +(defcustom magit-log-show-refname-after-summary nil + "Whether to show refnames after commit summaries. +This is useful if you use really long branch names." + :package-version '(magit . "2.2.0") + :group 'magit-log + :type 'boolean) + +(defcustom magit-log-wash-summary-hook + (list #'magit-highlight-squash-markers + #'magit-highlight-bracket-keywords) + "Functions used to highlight parts of each individual commit summary. + +These functions are called in order, in a buffer that containing the +first line of the commit message. They should set text properties as +they see fit, usually just `font-lock-face'. Before each function is +called, point is at the beginning of the buffer. + +See also the related `magit-revision-wash-message-hook'. You likely +want to use the same functions for both hooks." + :package-version '(magit . "4.3.0") + :group 'magit-log + :type 'hook + :options (list #'magit-highlight-squash-markers + #'magit-highlight-bracket-keywords)) + +(defcustom magit-log-header-line-function #'magit-log-header-line-sentence + "Function used to generate text shown in header line of log buffers." + :package-version '(magit . "2.12.0") + :group 'magit-log + :type `(radio (function-item ,#'magit-log-header-line-arguments) + (function-item ,#'magit-log-header-line-sentence) + function)) + +(defcustom magit-log-trace-definition-function #'magit-which-function + "Function used to determine the function at point. +This is used by the command `magit-log-trace-definition'. +You should prefer `magit-which-function' over `which-function' +because the latter may make use of Imenu's outdated cache." + :package-version '(magit . "3.0.0") + :group 'magit-log + :type `(radio (function-item ,#'magit-which-function) + (function-item ,#'which-function) + (function-item ,#'add-log-current-defun) + function)) + +(defcustom magit-log-color-graph-limit 256 + "Number of commits over which log graphs are not colored. +When showing more commits than specified, then the `--color' +argument is silently dropped. This is necessary because the +`ansi-color' library, which is used to turn control sequences +into faces, is just too slow." + :package-version '(magit . "4.0.0") + :group 'magit-log + :type 'number) + +(defcustom magit-log-show-signatures-limit 256 + "Number of commits over which signatures are not verified. +When showing more commits than specified by this option, then the +`--show-signature' argument, if specified, is silently dropped. +This is necessary because checking the signature of a large +number of commits is just too slow." + :package-version '(magit . "4.0.0") + :group 'magit-log + :type 'number) + +(defface magit-log-graph + '((((class color) (background light)) :foreground "grey30") + (((class color) (background dark)) :foreground "grey80")) + "Face for the graph part of the log output." + :group 'magit-faces) + +(defface magit-log-author + '((((class color) (background light)) + :foreground "firebrick" + :slant normal + :weight normal) + (((class color) (background dark)) + :foreground "tomato" + :slant normal + :weight normal)) + "Face for the author part of the log output." + :group 'magit-faces) + +(defface magit-log-date + '((((class color) (background light)) + :foreground "grey30" + :slant normal + :weight normal) + (((class color) (background dark)) + :foreground "grey80" + :slant normal + :weight normal)) + "Face for the date part of the log output." + :group 'magit-faces) + +(defface magit-header-line-log-select + '((t :inherit bold)) + "Face for the `header-line' in `magit-log-select-mode'." + :group 'magit-faces) + +;;;; File Log + +(defcustom magit-log-buffer-file-locked t + "Whether `magit-log-buffer-file-quick' uses a dedicated buffer." + :package-version '(magit . "2.7.0") + :group 'magit-commands + :group 'magit-log + :type 'boolean) + +;;;; Select Mode + +(defcustom magit-log-select-show-usage 'both + "Whether to show usage information when selecting a commit from a log. +The message can be shown in the `echo-area' or the `header-line', or in +`both' places. If the value isn't one of these symbols, then it should +be nil, in which case no usage information is shown." + :package-version '(magit . "2.1.0") + :group 'magit-log + :type '(choice (const :tag "In echo-area" echo-area) + (const :tag "In header-line" header-line) + (const :tag "In both places" both) + (const :tag "Nowhere"))) + +(defcustom magit-log-select-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width t + (nth 4 magit-log-margin)) + "Format of the margin in `magit-log-select-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-log-select-mode)) + +;;;; Cherry Mode + +(defcustom magit-cherry-sections-hook + (list #'magit-insert-cherry-headers + #'magit-insert-cherry-commits) + "Hook run to insert sections into the cherry buffer." + :package-version '(magit . "2.1.0") + :group 'magit-log + :type 'hook) + +(defcustom magit-cherry-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width t + (nth 4 magit-log-margin)) + "Format of the margin in `magit-cherry-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-cherry-mode)) + +;;;; Log Sections + +(defcustom magit-log-section-commit-count 10 + "How many recent commits to show in certain log sections. +How many recent commits `magit-insert-recent-commits' and +`magit-insert-unpulled-from-upstream-or-recent' (provided +the upstream isn't ahead of the current branch) show." + :package-version '(magit . "2.1.0") + :group 'magit-status + :type 'number) + +(defcustom magit-log-merged-commit-count 20 + "How many surrounding commits to show for `magit-log-merged'. +`magit-log-merged' will shows approximately half of this number +commits before and half after." + :package-version '(magit . "3.3.0") + :group 'magit-log + :type 'integer) + +;;; Arguments +;;;; Prefix Classes + +(defclass magit-log-prefix (transient-prefix) + ((history-key :initform 'magit-log) + (major-mode :initform 'magit-log-mode))) + +(defclass magit-log-refresh-prefix (magit-log-prefix) + ((history-key :initform 'magit-log) + (major-mode :initform nil))) + +;;;; Prefix Methods + +(cl-defmethod transient-init-value ((obj magit-log-prefix)) + (pcase-let ((`(,args ,files) + (magit-log--get-value 'magit-log-mode + magit-prefix-use-buffer-arguments))) + (when-let (((not (eq transient-current-command 'magit-dispatch))) + (file (magit-file-relative-name))) + (setq files (list file))) + (oset obj value (if files `(("--" ,@files) ,@args) args)))) + +(cl-defmethod transient-init-value ((obj magit-log-refresh-prefix)) + (oset obj value (if magit-buffer-log-files + `(("--" ,@magit-buffer-log-files) + ,@magit-buffer-log-args) + magit-buffer-log-args))) + +(cl-defmethod transient-set-value ((obj magit-log-prefix)) + (magit-log--set-value obj)) + +(cl-defmethod transient-save-value ((obj magit-log-prefix)) + (magit-log--set-value obj 'save)) + +;;;; Argument Access + +(defun magit-log-arguments (&optional mode) + "Return the current log arguments." + (if (memq transient-current-command '(magit-log magit-log-refresh)) + (magit--transient-args-and-files) + (magit-log--get-value (or mode 'magit-log-mode)))) + +(defun magit-log--get-value (mode &optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args files) + (cond + ((and (memq use-buffer-args '(always selected current)) + (eq major-mode mode)) + (setq args magit-buffer-log-args) + (setq files magit-buffer-log-files)) + ((when-let (((memq use-buffer-args '(always selected))) + (buffer (magit-get-mode-buffer + mode nil + (eq use-buffer-args 'selected)))) + (setq args (buffer-local-value 'magit-buffer-log-args buffer)) + (setq files (buffer-local-value 'magit-buffer-log-files buffer)) + t)) + ((plist-member (symbol-plist mode) 'magit-log-current-arguments) + (setq args (get mode 'magit-log-current-arguments))) + ((when-let ((elt (assq (intern (format "magit-log:%s" mode)) + transient-values))) + (setq args (cdr elt)) + t)) + (t + (setq args (get mode 'magit-log-default-arguments)))) + (list args files))) + +(defun magit-log--set-value (obj &optional save) + (pcase-let* ((obj (oref obj prototype)) + (mode (or (oref obj major-mode) major-mode)) + (key (intern (format "magit-log:%s" mode))) + (`(,args ,files) (magit--transient-args-and-files))) + (put mode 'magit-log-current-arguments args) + (when save + (setf (alist-get key transient-values) args) + (transient-save-values)) + (transient--history-push obj) + (setq magit-buffer-log-args args) + (unless (derived-mode-p 'magit-log-select-mode) + (setq magit-buffer-log-files files)) + (magit-refresh))) + +;;; Commands +;;;; Prefix Commands + +(transient-define-group magit-log-infix-arguments + ;; The grouping in git-log(1) appears to be guided by implementation + ;; details, so our logical grouping only follows it to an extend. + ;; Arguments that are "misplaced" here: + ;; 1. From "Commit Formatting". + ;; 2. From "Common Diff Options". + ;; 3. From unnamed first group. + ;; 4. Implemented by Magit. + ["Commit limiting" + :if magit-log-infix-arguments--show-p + (magit-log:-n) + (magit:--author) + (7 magit-log:--since) + (7 magit-log:--until) + (magit-log:--grep) + (7 "-i" "Search case-insensitive" ("-i" "--regexp-ignore-case")) + (7 "-I" "Invert search pattern" "--invert-grep") + (magit-log:-G) ;2 + (magit-log:-S) ;2 + (magit-log:-L) ;2 + (7 "=m" "Omit merges" "--no-merges") + (7 "=p" "First parent" "--first-parent")] + ["History simplification" + :if magit-log-infix-arguments--show-p + ( "-D" "Simplify by decoration" "--simplify-by-decoration") + (magit:--) + ( "-f" "Follow renames when showing single-file log" "--follow") ;3 + (6 "/s" "Only commits changing given paths" "--sparse") + (7 "/d" "Only selected commits plus meaningful history" "--dense") + (7 "/a" "Only commits existing directly on ancestry path" "--ancestry-path") + (6 "/f" "Do not prune history" "--full-history") + (7 "/m" "Prune some history" "--simplify-merges")] + ["Commit ordering" + :if magit-log-infix-arguments--show-p + (magit-log:--*-order) + ("-r" "Reverse order" "--reverse")] + ["Formatting" + :if magit-log-infix-arguments--show-p + ("-g" "Show graph" "--graph") ;1 + ("-c" "Show graph in color" "--color") ;2 + ("-d" "Show refnames" "--decorate") ;3 + ("=S" "Show signatures" "--show-signature") ;1 + ("-h" "Show header" "++header") ;4 + ("-p" "Show diffs" ("-p" "--patch")) ;2 + ("-s" "Show diffstats" "--stat")]) ;2 + +(defun magit-log-infix-arguments--show-p () + (if (eq (oref (transient-prefix-object) command) 'magit-log-refresh) + (eq major-mode 'magit-log-mode) + t)) + +;;;###autoload (autoload 'magit-log "magit-log" nil t) +(transient-define-prefix magit-log () + "Show a commit or reference log." + :man-page "git-log" + :class 'magit-log-prefix + 'magit-log-infix-arguments + [["Log" + ("l" magit-log-current) + ("o" "other" magit-log-other) + ("h" "HEAD" magit-log-head :level 0) + ("u" "related" magit-log-related)] + ["" + ("L" "local branches" magit-log-branches) + ("b" "all branches" magit-log-all-branches) + ("a" "all references" magit-log-all) + ("B" "matching branches" magit-log-matching-branches :level 7) + ("T" "matching tags" magit-log-matching-tags :level 7) + ("m" "merged" magit-log-merged :level 7)] + ["Reflog" + ("r" "current" magit-reflog-current) + ("O" "other" magit-reflog-other) + ("H" "HEAD" magit-reflog-head)] + [:if magit--any-wip-mode-enabled-p + :description "Wiplog" + ("i" "index" magit-wip-log-index) + ("w" "worktree" magit-wip-log-worktree)] + ["Other" + ("s" "shortlog" magit-shortlog)]]) + +;;;###autoload (autoload 'magit-log-refresh "magit-log" nil t) +(transient-define-prefix magit-log-refresh () + "Change the arguments used for the log(s) in the current buffer." + :man-page "git-log" + :class 'magit-log-refresh-prefix + magit-log-infix-arguments + [:if-not-mode magit-log-mode + :description "Arguments" + (magit-log:-n) + (magit-log:--*-order) + ("-g" "Show graph" "--graph") + ("-c" "Show graph in color" "--color") + ("-d" "Show refnames" "--decorate")] + [["Refresh" + ("g" "buffer" magit-log-refresh) + ("s" "buffer and set defaults" transient-set-and-exit) + ("w" "buffer and save defaults" transient-save-and-exit)] + ["Margin" + (magit-toggle-margin) + (magit-cycle-margin-style) + (magit-toggle-margin-details) + (magit-toggle-log-margin-style)] + [:if-mode magit-log-mode + :description "Toggle" + ("b" "buffer lock" magit-toggle-buffer-lock)]] + (interactive) + (cond + ((not (eq transient-current-command 'magit-log-refresh)) + (pcase major-mode + ('magit-reflog-mode + (user-error "Cannot change log arguments in reflog buffers")) + ('magit-cherry-mode + (user-error "Cannot change log arguments in cherry buffers"))) + (transient-setup 'magit-log-refresh)) + (t + (pcase-let ((`(,args ,files) (magit-log-arguments))) + (setq magit-buffer-log-args args) + (unless (derived-mode-p 'magit-log-select-mode) + (setq magit-buffer-log-files files))) + (magit-refresh)))) + +;;;; Infix Commands + +(transient-define-argument magit-log:-n () + :description "Limit number of commits" + :class 'transient-option + ;; For historic reasons (and because it easy to guess what "-n" + ;; stands for) this is the only argument where we do not use the + ;; long argument ("--max-count"). + :shortarg "-n" + :argument "-n" + :reader #'transient-read-number-N+) + +(transient-define-argument magit:--author () + :description "Limit to author" + :class 'transient-option + :key "-A" + :argument "--author=" + :reader #'magit-transient-read-person) + +(transient-define-argument magit-log:--since () + :description "Limit to commits since" + :class 'transient-option + :key "=s" + :argument "--since=" + :reader #'transient-read-date) + +(transient-define-argument magit-log:--until () + :description "Limit to commits until" + :class 'transient-option + :key "=u" + :argument "--until=" + :reader #'transient-read-date) + +(transient-define-argument magit-log:--*-order () + :description "Order commits by" + :class 'transient-switches + :key "-o" + :argument-format "--%s-order" + :argument-regexp "\\(--\\(topo\\|author-date\\|date\\)-order\\)" + :choices '("topo" "author-date" "date")) + +(transient-define-argument magit-log:--grep () + :description "Search messages" + :class 'transient-option + :key "-F" + :argument "--grep=") + +(transient-define-argument magit-log:-G () + :description "Search changes" + :class 'transient-option + :argument "-G") + +(transient-define-argument magit-log:-S () + :description "Search occurrences" + :class 'transient-option + :argument "-S") + +(transient-define-argument magit-log:-L () + :description "Trace line evolution" + :class 'transient-option + :argument "-L" + :reader #'magit-read-file-trace) + +(defun magit-read-file-trace (&rest _ignored) + (let ((file (magit-read-file-from-rev "HEAD" "File")) + (trace (magit-read-string "Trace"))) + (concat trace ":" file))) + +;;;; Setup Commands + +(defvar-keymap magit-log-read-revs-map + :parent crm-local-completion-map + "SPC" #'self-insert-command) + +(defun magit-log-read-revs (&optional use-current) + (or (and use-current (and-let* ((buf (magit-get-current-branch))) (list buf))) + (let ((crm-separator "\\(\\.\\.\\.?\\|[, ]\\)") + (crm-local-completion-map magit-log-read-revs-map)) + (split-string (magit-completing-read-multiple + "Log rev,s: " + (magit-list-refnames nil t) + nil nil nil 'magit-revision-history + (or (magit-branch-or-commit-at-point) + (and (not use-current) + (magit-get-previous-branch))) + nil t) + "[, ]" t)))) + +(defun magit-log-read-pattern (option) + "Read a string from the user to pass as parameter to OPTION." + (magit-read-string (format "Type a pattern to pass to %s" option))) + +;;;###autoload (autoload 'magit-log-current "magit-log" nil t) +(transient-define-suffix magit-log-current (&optional args files) + "Show log for the current branch, or `HEAD' if no branch is checked out." + :description (##if (magit-get-current-branch) "current" "HEAD") + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list (or (magit-get-current-branch) "HEAD")) + args files)) + +;;;###autoload +(defun magit-log-head (&optional args files) + "Show log for `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list "HEAD") args files)) + +;;;###autoload +(defun magit-log-related (revs &optional args files) + "Show log for the current branch, its upstream and its push target. +When the upstream is a local branch, then also show its own +upstream. When `HEAD' is detached, then show log for that, the +previously checked out branch and its upstream and push-target." + (interactive + (cons (let ((current (magit-get-current-branch)) + head rebase target upstream upup) + (unless current + (setq rebase (magit-rebase--get-state-lines "head-name")) + (cond (rebase + (setq rebase (magit-ref-abbrev rebase)) + (setq current rebase) + (setq head "HEAD")) + ((setq current (magit-get-previous-branch))))) + (cond (current + (setq current + (magit--propertize-face current 'magit-branch-local)) + (setq target (magit-get-push-branch current t)) + (setq upstream (magit-get-upstream-branch current)) + (when upstream + (setq upup (and (magit-local-branch-p upstream) + (magit-get-upstream-branch upstream))))) + ((setq head "HEAD"))) + (delq nil (list current head target upstream upup))) + (magit-log-arguments))) + (magit-log-setup-buffer revs args files)) + +;;;###autoload +(defun magit-log-other (revs &optional args files) + "Show log for one or more revs read from the minibuffer. +The user can input any revision or revisions separated by a +space, or even ranges, but only branches and tags, and a +representation of the commit at point, are available as +completion candidates." + (interactive (cons (magit-log-read-revs) + (magit-log-arguments))) + (magit-log-setup-buffer revs args files)) + +;;;###autoload +(defun magit-log-branches (&optional args files) + "Show log for all local branches and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--branches") + (list "HEAD" "--branches")) + args files)) + +;;;###autoload +(defun magit-log-matching-branches (pattern &optional args files) + "Show log for all branches matching PATTERN and `HEAD'." + (interactive (cons (magit-log-read-pattern "--branches") (magit-log-arguments))) + (magit-log-setup-buffer + (list "HEAD" (format "--branches=%s" pattern)) + args files)) + +;;;###autoload +(defun magit-log-matching-tags (pattern &optional args files) + "Show log for all tags matching PATTERN and `HEAD'." + (interactive (cons (magit-log-read-pattern "--tags") (magit-log-arguments))) + (magit-log-setup-buffer + (list "HEAD" (format "--tags=%s" pattern)) + args files)) + +;;;###autoload +(defun magit-log-all-branches (&optional args files) + "Show log for all local and remote branches and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--branches" "--remotes") + (list "HEAD" "--branches" "--remotes")) + args files)) + +;;;###autoload +(defun magit-log-all (&optional args files) + "Show log for all references and `HEAD'." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (if (magit-get-current-branch) + (list "--all") + (list "HEAD" "--all")) + args files)) + +;;;###autoload +(defun magit-log-buffer-file (&optional follow beg end) + "Show log for the blob or file visited in the current buffer. +With a prefix argument or when `--follow' is an active log +argument, then follow renames. When the region is active, +restrict the log to the lines that the region touches." + (interactive (cons current-prefix-arg (magit-file-region-line-numbers))) + (require 'magit) + (if-let ((file (magit-file-relative-name))) + (magit-log-setup-buffer + (list (or magit-buffer-refname + (magit-get-current-branch) + "HEAD")) + (let ((args (car (magit-log-arguments)))) + (when (and follow (not (member "--follow" args))) + (push "--follow" args)) + (when (and beg end) + (setq args (cons (format "-L%s,%s:%s" beg end file) + (cl-delete "-L" args :test + #'string-prefix-p))) + (setq file nil)) + args) + (and file (list file)) + magit-log-buffer-file-locked) + (user-error "Buffer isn't visiting a file"))) + +;;;###autoload +(defun magit-log-trace-definition (file fn rev) + "Show log for the definition at point." + (interactive (list (or (magit-file-relative-name) + (user-error "Buffer isn't visiting a file")) + (or (funcall magit-log-trace-definition-function) + (user-error "No function at point found")) + (or magit-buffer-refname + (magit-get-current-branch) + "HEAD"))) + (require 'magit) + (magit-log-setup-buffer + (list rev) + (cons (format "-L:%s%s:%s" + (string-replace ":" "\\:" (regexp-quote fn)) + (if (derived-mode-p 'lisp-mode 'emacs-lisp-mode) + ;; Git doesn't treat "-" the same way as + ;; "_", leading to false-positives such as + ;; "foo-suffix" being considered a match + ;; for "foo". Wing it. + "\\( \\|$\\)" + ;; We could use "\\b" here, but since Git + ;; already does something equivalent, that + ;; isn't necessary. + "") + file) + (cl-delete "-L" (car (magit-log-arguments)) + :test #'string-prefix-p)) + nil magit-log-buffer-file-locked)) + +(defun magit-diff-trace-definition () + "Show log for the definition at point in a diff." + (interactive) + (pcase-let ((`(,buf ,pos) (magit-diff-visit-file--noselect))) + (magit--with-temp-position buf pos + (call-interactively #'magit-log-trace-definition)))) + +;;;###autoload +(defun magit-log-merged (commit branch &optional args files) + "Show log for the merge of COMMIT into BRANCH. + +More precisely, find merge commit M that brought COMMIT into +BRANCH, and show the log of the range \"M^1..M\". If COMMIT is +directly on BRANCH, then show approximately +`magit-log-merged-commit-count' surrounding commits instead. + +This command requires git-when-merged, which is available from +https://github.com/mhagger/git-when-merged." + (interactive + (append (let ((commit (magit-read-branch-or-commit "Log merge of commit"))) + (list commit + (magit-read-other-branch "Merged into" commit))) + (magit-log-arguments))) + (unless (magit-git-executable-find "git-when-merged") + (user-error "This command requires git-when-merged (%s)" + "https://github.com/mhagger/git-when-merged")) + (let (exit m) + (with-temp-buffer + (save-excursion + (setq exit (magit-process-git t "when-merged" "-c" + (magit-abbrev-arg) + commit branch))) + (setq m (buffer-substring-no-properties (point) (line-end-position)))) + (if (zerop exit) + (magit-log-setup-buffer (list (format "%s^1..%s" m m)) + args files nil commit) + ;; Output: "". + ;; This is not the same as `string-trim'. + (setq m (string-trim-left (substring m (string-match " " m)))) + (if (equal m "Commit is directly on this branch.") + (let* ((from (format "%s~%d" commit + (/ magit-log-merged-commit-count 2))) + (to (- (car (magit-rev-diff-count branch commit t)) + (/ magit-log-merged-commit-count 2))) + (to (if (<= to 0) + branch + (format "%s~%s" branch to)))) + (unless (magit-rev-verify-commit from) + (setq from (magit-git-string "rev-list" "--max-parents=0" + commit))) + (magit-log-setup-buffer (list (concat from ".." to)) + (cons "--first-parent" args) + files nil commit)) + (user-error "Could not find when %s was merged into %s: %s" + commit branch m))))) + +;;;; Limit Commands + +(defun magit-log-toggle-commit-limit () + "Toggle the number of commits the current log buffer is limited to. +If the number of commits is currently limited, then remove that +limit. Otherwise set it to 256." + (interactive) + (magit-log-set-commit-limit (lambda (&rest _) nil))) + +(defun magit-log-double-commit-limit () + "Double the number of commits the current log buffer is limited to." + (interactive) + (magit-log-set-commit-limit '*)) + +(defun magit-log-half-commit-limit () + "Half the number of commits the current log buffer is limited to." + (interactive) + (magit-log-set-commit-limit '/)) + +(defun magit-log-set-commit-limit (fn) + (let* ((val magit-buffer-log-args) + (arg (seq-find (##string-match "^-n\\([0-9]+\\)?$" %) val)) + (num (and arg (string-to-number (match-string 1 arg)))) + (num (if num (funcall fn num 2) 256))) + (setq val (remove arg val)) + (setq magit-buffer-log-args + (if (and num (> num 0)) + (cons (format "-n%d" num) val) + val))) + (magit-refresh)) + +(defun magit-log-get-commit-limit (&optional args) + (and-let* ((str (seq-find (##string-match "^-n\\([0-9]+\\)?$" %) + (or args magit-buffer-log-args)))) + (string-to-number (match-string 1 str)))) + +;;;; Mode Commands + +(defun magit-log-bury-buffer (&optional arg) + "Bury the current buffer or the revision buffer in the same frame. +Like `magit-mode-bury-buffer' (which see) but with a negative +prefix argument instead bury the revision buffer, provided it +is displayed in the current frame." + (interactive "p") + (if (< arg 0) + (let* ((buf (magit-get-mode-buffer 'magit-revision-mode)) + (win (and buf (get-buffer-window buf (selected-frame))))) + (if win + (with-selected-window win + (with-current-buffer buf + (magit-mode-bury-buffer (> (abs arg) 1)))) + (user-error "No revision buffer in this frame"))) + (magit-mode-bury-buffer (> arg 1)))) + +;;;###autoload +(defun magit-log-move-to-parent (&optional n) + "Move to the Nth parent of the current commit." + (interactive "p") + (when (and (derived-mode-p 'magit-log-mode) + (magit-section-match 'commit)) + (let* ((section (magit-current-section)) + (parent-rev (format "%s^%s" (oref section value) (or n 1)))) + (if-let ((parent-hash (magit-rev-parse "--short" parent-rev))) + (if-let ((parent (seq-find (##equal (oref % value) parent-hash) + (magit-section-siblings section 'next)))) + (magit-section-goto parent) + (user-error + (substitute-command-keys + (concat "Parent " parent-hash " not found. Try typing " + "\\[magit-log-double-commit-limit] first")))) + (user-error "Parent %s does not exist" parent-rev))))) + +(defun magit-log-move-to-revision (rev) + "Read a revision and move to it in current log buffer. + +If the chosen reference or revision isn't being displayed in +the current log buffer, then inform the user about that and do +nothing else. + +If invoked outside any log buffer, then display the log buffer +of the current repository first; creating it if necessary." + (interactive + (list (or (magit-completing-read + "In log, jump to" + (magit-list-refnames nil t) + nil nil nil 'magit-revision-history + (or (and-let* ((rev (magit-commit-at-point))) + (magit-rev-fixup-target rev)) + (magit-get-current-branch))) + (user-error "Nothing selected")))) + (with-current-buffer + (cond ((derived-mode-p 'magit-log-mode) + (current-buffer)) + ((and-let* ((buf (magit-get-mode-buffer 'magit-log-mode))) + (pop-to-buffer-same-window buf))) + (t + (apply #'magit-log-all-branches (magit-log-arguments)))) + (unless (magit-log-goto-commit-section (magit-rev-abbrev rev)) + (user-error "%s isn't visible in the current log buffer" rev)))) + +;;;; Shortlog Commands + +;;;###autoload (autoload 'magit-shortlog "magit-log" nil t) +(transient-define-prefix magit-shortlog () + "Show a history summary." + :man-page "git-shortlog" + :value '("--numbered" "--summary") + ["Arguments" + ("-n" "Sort by number of commits" ("-n" "--numbered")) + ("-s" "Show commit count summary only" ("-s" "--summary")) + ("-e" "Show email addresses" ("-e" "--email")) + ("-g" "Group commits by" "--group=" + :choices ("author" "committer" "trailer:")) + (7 "-f" "Format string" "--format=") + (7 "-w" "Linewrap" "-w" :class transient-option)] + ["Shortlog" + ("s" "since" magit-shortlog-since) + ("r" "range" magit-shortlog-range)]) + +(defun magit-git-shortlog (rev args) + (let ((dir default-directory)) + (with-current-buffer (get-buffer-create "*magit-shortlog*") + (setq default-directory dir) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (save-excursion + (magit-git-insert "shortlog" args rev)) + (switch-to-buffer-other-window (current-buffer)))))) + +;;;###autoload +(defun magit-shortlog-since (rev args) + "Show a history summary for commits since REV." + (interactive + (list (magit-read-branch-or-commit "Shortlog since" (magit-get-current-tag)) + (transient-args 'magit-shortlog))) + (magit-git-shortlog (concat rev "..") args)) + +;;;###autoload +(defun magit-shortlog-range (rev-or-range args) + "Show a history summary for commit or range REV-OR-RANGE." + (interactive + (list (magit-read-range-or-commit "Shortlog for revision or range") + (transient-args 'magit-shortlog))) + (magit-git-shortlog rev-or-range args)) + +;;;; Movement Commands + +(defvar magit-reference-movement-faces + '(magit-tag + magit-branch-remote + magit-branch-remote-head + magit-branch-local + magit-branch-current + magit-branch-upstream + magit-branch-warning + magit-head + magit-refname + magit-refname-stash + magit-refname-wip + magit-refname-pullreq)) + +(defvar-keymap magit-reference-navigation-repeat-map + :repeat t + "p" #'magit-previous-reference + "n" #'magit-next-reference + "r" #'magit-next-reference) + +(defun magit-previous-reference () + "Move to the previous Git reference appearing in the current buffer. + +Move to the previous location that uses a face appearing in +`magit-reference-movement-faces'. If `repeat-mode' is enabled, +this command and its counterpart can be repeated using \ +\\\ +\\[magit-previous-reference] and \\[magit-next-reference]." + (interactive) + (magit-next-reference t)) + +(defun magit-next-reference (&optional previous) + "Move to the next Git reference appearing in the current buffer. + +Move to the next location that uses a face appearing in +`magit-reference-movement-faces'. If `repeat-mode' is enabled, +this command and its counterpart can be repeated using \ +\\\ +\\[magit-previous-reference] and \\[magit-next-reference]." + (interactive) + (catch 'found + (let ((pos (point))) + (while (and (not (eobp)) + (setq pos (if previous + (previous-single-property-change pos 'face) + (next-single-property-change pos 'face)))) + (when (cl-intersection (ensure-list (get-text-property pos 'face)) + magit-reference-movement-faces) + (throw 'found (goto-char pos)))) + (message "No more references")))) + +;;; Log Mode + +(defvar magit-log-disable-graph-hack-args + '("-G" "--grep" "--author") + "Arguments which disable the graph speedup hack.") + +(defvar-keymap magit-log-mode-map + :doc "Keymap for `magit-log-mode'." + :parent magit-mode-map + "C-c C-b" #'magit-go-backward + "C-c C-f" #'magit-go-forward + "C-c C-n" #'magit-log-move-to-parent + "j" #'magit-log-move-to-revision + "=" #'magit-log-toggle-commit-limit + "+" #'magit-log-double-commit-limit + "-" #'magit-log-half-commit-limit + "q" #'magit-log-bury-buffer) + +(define-derived-mode magit-log-mode magit-mode "Magit Log" + "Mode for looking at Git log. + +This mode is documented in info node `(magit)Log Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-branch] to see available branch commands. +Type \\[magit-merge] to merge the branch or commit at point. +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-log-mode-map}" + :interactive nil + :group 'magit-log + (magit-hack-dir-local-variables) + (setq magit--imenu-item-types 'commit)) + +(put 'magit-log-mode 'magit-log-default-arguments + '("--graph" "-n256" "--decorate")) + +(defun magit-log-setup-buffer (revs args files &optional locked focus) + (require 'magit) + (with-current-buffer + (magit-setup-buffer #'magit-log-mode locked + (magit-buffer-revisions revs) + (magit-buffer-log-args args) + (magit-buffer-log-files files)) + (when (if focus + (magit-log-goto-commit-section focus) + (magit-log-goto-same-commit)) + (magit-section-update-highlight)) + (current-buffer))) + +(defun magit-log-refresh-buffer () + (let ((revs magit-buffer-revisions) + (args magit-buffer-log-args) + (files magit-buffer-log-files) + (limit (magit-log-get-commit-limit))) + (magit-set-header-line-format + (funcall magit-log-header-line-function revs args files)) + (unless (length= files 1) + (setq args (remove "--follow" args))) + (when (and (car magit-log-remove-graph-args) + (let ((re (concat "^" (regexp-opt magit-log-remove-graph-args)))) + (seq-some (##string-match-p re %) args))) + (setq args (remove "--graph" args))) + (setq args (magit-log--maybe-drop-color-graph args limit)) + (when-let* ((limit limit) + (limit (* 2 limit)) ; increase odds for complete graph + (count (and (length= revs 1) + (> limit 1024) ; otherwise it's fast enough + (setq revs (car revs)) + (not (string-search ".." revs)) + (not (member revs '("--all" "--branches"))) + (not (seq-some + (lambda (arg) + (seq-some (##string-prefix-p % arg) + magit-log-disable-graph-hack-args)) + args)) + (magit-git-string "rev-list" "--count" + "--first-parent" args revs)))) + (setq revs (if (< (string-to-number count) limit) + revs + (format "%s~%s..%s" revs limit revs)))) + (let ((delay (cl-find-if (##member % '("++header" "--patch" "--stat")) + args))) + (setq magit-section-inhibit-markers (if delay 'delay t)) + (setq magit-section-insert-in-reverse (not delay))) + (magit-insert-section (logbuf) + (magit--insert-log t revs args files)))) + +(defvar-local magit-log--color-graph nil) + +(defun magit-log--maybe-drop-color-graph (args limit) + (if (member "--color" args) + (if (cond ((not (member "--graph" args))) + ((not magit-log-color-graph-limit) nil) + ((not limit) + (message "Dropping --color because -n isn't set (see %s)" + 'magit-log-color-graph-limit)) + ((> limit magit-log-color-graph-limit) + (message "Dropping --color because -n is larger than %s" + 'magit-log-color-graph-limit))) + (progn (setq args (remove "--color" args)) + (setq magit-log--color-graph nil)) + (setq magit-log--color-graph t)) + (setq magit-log--color-graph nil)) + args) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-log-mode)) + (append magit-buffer-revisions + (if (and magit-buffer-revisions magit-buffer-log-files) + (cons "--" magit-buffer-log-files) + magit-buffer-log-files))) + +(defun magit-log-header-line-arguments (revs args files) + "Return string describing some of the used arguments." + (mapconcat (##if (string-search " " %) (prin1 %) %) + `("git" "log" ,@args ,@revs "--" ,@files) + " ")) + +(defun magit-log-header-line-sentence (revs args files) + "Return string containing all arguments." + (concat "Commits in " + (string-join revs " ") + (and (member "--reverse" args) + " in reverse") + (and files (concat " touching " + (string-join files " "))) + (seq-some (##and (string-prefix-p "-L" %) + (concat " " %)) + args))) + +(defun magit-insert-log (revs &optional args files) + (declare (obsolete magit--insert-log "Magit 4.0.0")) + (magit--insert-log nil revs args files)) + +(defun magit--insert-log (keep-error revs &optional args files) + "Insert a log section. +Do not add this to a hook variable." + (declare (indent defun)) + (setq magit-section-preserve-visibility t) ; TODO do it here? + (let ((magit-git-global-arguments + (remove "--literal-pathspecs" magit-git-global-arguments))) + (magit--git-wash (apply-partially #'magit-log-wash-log 'log) keep-error + "log" + (format "--format=%s%%h%%x0c%s%%x0c%s%%x0c%%aN%%x0c%s%%x0c%%s%s" + (if (and (member "--left-right" args) + (not (member "--graph" args))) + "%m " + "") + (if (member "--decorate" args) "%D" "") + (if (not (member "--show-signature" args)) + "" + (setq args (remove "--show-signature" args)) + (let ((limit (magit-log-get-commit-limit args))) + (cond + ((not limit) + (message + "Dropping --show-signature because -n isn't set (see %s)" + 'magit-log-show-signatures-limit) + "") + ((> limit magit-log-show-signatures-limit) + (message + "Dropping --show-signature because -n is larger than %s" + 'magit-log-show-signatures-limit) + "") + ("%G?")))) + (if magit-log-margin-show-committer-date "%ct" "%at") + (if (member "++header" args) + (if (member "--graph" (setq args (remove "++header" args))) + (concat "\n" magit-log-revision-headers-format "\n") + (concat "\n" magit-log-revision-headers-format "\n")) + "")) + (progn + (when-let ((order (seq-find (##string-match "^\\+\\+order=\\(.+\\)$" %) + args))) + (setq args (cons (format "--%s-order" (match-string 1 order)) + (remove order args)))) + (when (member "--decorate" args) + (setq args (cons "--decorate=full" (remove "--decorate" args)))) + (when (member "--reverse" args) + (setq args (remove "--graph" args))) + (setq args (magit-diff--maybe-add-stat-arguments args)) + args) + "--use-mailmap" "--no-prefix" revs "--" files))) + +(cl-defmethod magit-menu-common-value ((_section magit-commit-section)) + (or (magit-diff--region-range) + (oref (magit-current-section) value))) + +(defvar-keymap magit-commit-section-map + :doc "Keymap for `commit' sections." + " " #'magit-show-commit + "<3>" (magit-menu-item "Apply %x" #'magit-cherry-apply) + "<2>" (magit-menu-item "Show commit %x" #'magit-show-commit + '(:visible (not (region-active-p)))) + "<1>" (magit-menu-item "Diff %x" #'magit-diff-range + '(:visible (region-active-p)))) + +(defvar-keymap magit-module-commit-section-map + :doc "Keymap for `module-commit' sections." + :parent magit-commit-section-map) + +(defconst magit-log-heading-re + ;; Note: A form feed instead of a null byte is used as the delimiter + ;; because using the latter interferes with the graph prefix when + ;; ++header is used. + (concat "^" + "\\(?4:[-_/|\\*o<>. ]*\\)" ; graph + "\\(?1:[0-9a-fA-F]+\\)? " ; hash + "\\(?3:[^ \n]+\\)? " ; refs + "\\(?7:[BGUXYREN]\\)? " ; gpg + "\\(?5:[^ \n]*\\) " ; author + ;; Note: Date is optional because, prior to Git v2.19.0, + ;; `git rebase -i --root` corrupts the root's author date. + "\\(?6:[^ \n]*\\) " ; date + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-cherry-re + (concat "^" + "\\(?8:[-+]\\) " ; cherry + "\\(?1:[0-9a-fA-F]+\\) " ; hash + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-module-re + (concat "^" + "\\(?:\\(?11:[<>]\\) \\)?" ; side + "\\(?1:[0-9a-fA-F]+\\) " ; hash + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-bisect-vis-re + (concat "^" + "\\(?4:[-_/|\\*o<>. ]*\\)" ; graph + "\\(?1:[0-9a-fA-F]+\\)?\0" ; hash + "\\(?3:[^\0\n]+\\)?\0" ; refs + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-bisect-log-re + (concat "^# " + "\\(?3:[^: \n]+:\\) " ; "refs" + "\\[\\(?1:[^]\n]+\\)\\] " ; hash + "\\(?2:.*\\)$")) ; msg + +(defconst magit-log-reflog-re + (concat "^" + "\\(?1:[^\0\n]+\\)\0" ; hash + "\\(?5:[^\0\n]*\\)\0" ; author + "\\(?:\\(?:[^@\n]+@{\\(?6:[^}\n]+\\)}\0" ; date + ;;; refsub + "\\(?10:merge \\|autosave \\|restart \\|rewritten \\|[^:\n]+: \\)?" + "\\(?2:.*\\)\\)\\|\0\\)$")) ; msg + +(defconst magit-reflog-subject-re + (concat "\\(?1:[^ ]+\\) ?" ; command + "\\(?2:\\(?: ?-[^ ]+\\)+\\)?" ; option + "\\(?: ?(\\(?3:[^)]+\\))\\)?")) ; type + +(defconst magit-log-stash-re + (concat "^" + "\\(?1:[^\0\n]+\\)\0" ; "hash" + "\\(?5:[^\0\n]*\\)\0" ; author + "\\(?6:[^\0\n]+\\)\0" ; date + "\\(?2:.*\\)$")) ; msg + +(defvar magit-log-count nil) + +(defun magit-log-wash-log (style args) + (setq args (flatten-tree args)) + (when (if (derived-mode-p 'magit-log-mode) + magit-log--color-graph + (and (member "--graph" args) + (member "--color" args))) + (let ((ansi-color-apply-face-function + (lambda (beg end face) + (put-text-property beg end 'font-lock-face + (or face 'magit-log-graph))))) + (ansi-color-apply-on-region (point-min) (point-max)))) + (when (eq style 'cherry) + (reverse-region (point-min) (point-max))) + (let ((magit-log-count 0)) + (when (looking-at "^\\.\\.\\.") + (magit-delete-line)) + (magit-wash-sequence (apply-partially #'magit-log-wash-rev style + (magit-abbrev-length))) + (if (derived-mode-p 'magit-log-mode 'magit-reflog-mode) + (when (eq magit-log-count (magit-log-get-commit-limit)) + (magit-insert-section (longer) + (insert-text-button + (substitute-command-keys + (format "Type \\<%s>\\[%s] to show more history" + 'magit-log-mode-map + 'magit-log-double-commit-limit)) + 'action (lambda (_button) + (magit-log-double-commit-limit)) + 'follow-link t + 'mouse-face 'magit-section-highlight))) + (insert ?\n)))) + +(cl-defun magit-log-wash-rev (style abbrev) + (when (derived-mode-p 'magit-log-mode 'magit-reflog-mode) + (cl-incf magit-log-count)) + (looking-at (pcase style + ('log magit-log-heading-re) + ('cherry magit-log-cherry-re) + ('module magit-log-module-re) + ('reflog magit-log-reflog-re) + ('stash magit-log-stash-re) + ('bisect-vis magit-log-bisect-vis-re) + ('bisect-log magit-log-bisect-log-re))) + (magit-bind-match-strings + (hash msg refs graph author date gpg cherry _ refsub side) nil + (setq msg (substring-no-properties msg)) + (when refs + (setq refs (substring-no-properties refs))) + (let ((align (or (eq style 'cherry) + (not (member "--stat" magit-buffer-log-args)))) + (non-graph-re (if (eq style 'bisect-vis) + magit-log-bisect-vis-re + magit-log-heading-re))) + (magit-delete-line) + ;; If the reflog entries have been pruned, the output of `git + ;; reflog show' includes a partial line that refers to the hash + ;; of the youngest expired reflog entry. + (when (and (eq style 'reflog) (not date)) + (cl-return-from magit-log-wash-rev t)) + (magit-insert-section + ((eval (pcase style + ('stash 'stash) + ('module 'module-commit) + (_ 'commit))) + hash) + (setq hash (propertize (if (eq style 'bisect-log) + (magit-rev-parse "--short" hash) + hash) + 'font-lock-face + (pcase (and gpg (aref gpg 0)) + (?G 'magit-signature-good) + (?B 'magit-signature-bad) + (?U 'magit-signature-untrusted) + (?X 'magit-signature-expired) + (?Y 'magit-signature-expired-key) + (?R 'magit-signature-revoked) + (?E 'magit-signature-error) + (?N 'magit-hash) + (_ 'magit-hash)))) + (when cherry + (when (and (derived-mode-p 'magit-refs-mode) + magit-refs-show-commit-count) + (insert (make-string (1- magit-refs-focus-column-width) ?\s))) + (insert (propertize cherry 'font-lock-face + (if (string= cherry "-") + 'magit-cherry-equivalent + 'magit-cherry-unmatched))) + (insert ?\s)) + (when side + (insert (propertize side 'font-lock-face + (if (string= side "<") + 'magit-cherry-equivalent + 'magit-cherry-unmatched))) + (insert ?\s)) + (when align + (insert hash ?\s)) + (when graph + (insert graph)) + (unless align + (insert hash ?\s)) + (when (and refs (not magit-log-show-refname-after-summary)) + (insert (magit-format-ref-labels refs) ?\s)) + (when (eq style 'reflog) + (insert (format "%-2s " (1- magit-log-count))) + (when refsub + (insert (magit-reflog-format-subject + (substring refsub 0 + (if (string-search ":" refsub) -2 -1)))))) + (insert (magit-log--wash-summary msg)) + (when (and refs magit-log-show-refname-after-summary) + (insert ?\s) + (insert (magit-format-ref-labels refs))) + (insert ?\n) + (when (memq style '(log reflog stash)) + (goto-char (line-beginning-position)) + (when (and refsub + (string-match "\\`\\([^ ]\\) \\+\\(..\\)\\(..\\)" date)) + (setq date (+ (string-to-number (match-string 1 date)) + (* (string-to-number (match-string 2 date)) 60 60) + (* (string-to-number (match-string 3 date)) 60)))) + (magit-log-format-margin hash author date)) + (when (and (eq style 'cherry) + (magit-buffer-margin-p)) + (apply #'magit-log-format-margin hash + (split-string (magit-rev-format "%aN%x00%ct" hash) "\0"))) + (when (and graph + (not (eobp)) + (not (looking-at non-graph-re))) + (when (looking-at "") + (magit-insert-heading) + (delete-char 1) + (magit-insert-section (commit-header) + (forward-line) + (magit-insert-heading) + (re-search-forward "") + (delete-char -1) + (forward-char) + (insert ?\n)) + (delete-char 1)) + (if (looking-at "^\\(---\\|\n\s\\|\ndiff\\)") + (let ((limit (save-excursion + (and (re-search-forward non-graph-re nil t) + (match-beginning 0))))) + (unless (oref magit-insert-section--current content) + (magit-insert-heading)) + (delete-char (if (looking-at "\n") 1 4)) + (magit-diff-wash-diffs (list "--stat") limit)) + (when align + (setq align (make-string (1+ abbrev) ? ))) + (when (and (not (eobp)) (not (looking-at non-graph-re))) + (when align + (setq align (make-string (1+ abbrev) ? ))) + (while (and (not (eobp)) (not (looking-at non-graph-re))) + (when align + (save-excursion (insert align))) + (forward-line) + (magit-make-margin-overlay)) + ;; When `--format' is used and its value isn't one of the + ;; predefined formats, then `git-log' does not insert a + ;; separator line. + (save-excursion + (forward-line -1) + (looking-at "[-_/|\\*o<>. ]*")) + (setq graph (match-string 0)) + (unless (string-match-p "[/\\.]" graph) + (insert graph ?\n)))))))) + t) + +(defun magit-log--wash-summary (summary) + (with-temp-buffer + (save-excursion (insert summary)) + (run-hook-wrapped 'magit-log-wash-summary-hook + (lambda (fn) (prog1 nil (save-excursion (funcall fn))))) + (buffer-string))) + +(defun magit-log-maybe-show-more-commits (section) + "When point is at the end of a log buffer, insert more commits. + +Log buffers end with a button \"Type + to show more history\". +When the use of a section movement command puts point on that +button, then automatically show more commits, without the user +having to press \"+\". + +This function is called by `magit-section-movement-hook' and +exists mostly for backward compatibility reasons." + (when (and (eq (oref section type) 'longer) + magit-log-auto-more) + (magit-log-double-commit-limit) + (forward-line -1) + (magit-section-forward))) + +(add-hook 'magit-section-movement-hook #'magit-log-maybe-show-more-commits) + +(defvar magit--update-revision-buffer nil) + +(defun magit-log-maybe-update-revision-buffer (&optional _) + "When moving in a log or cherry buffer, update the revision buffer. +If there is no revision buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-log-mode 'magit-cherry-mode 'magit-reflog-mode) + (magit--maybe-update-revision-buffer))) + +(add-hook 'magit-section-movement-hook #'magit-log-maybe-update-revision-buffer) + +(defun magit--maybe-update-revision-buffer () + (when-let* ((commit (magit-section-value-if 'commit)) + (buffer (magit-get-mode-buffer 'magit-revision-mode nil t))) + (if magit--update-revision-buffer + (setq magit--update-revision-buffer (list commit buffer)) + (setq magit--update-revision-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (let ((args (let ((magit-direct-use-buffer-arguments 'selected)) + (magit-show-commit--arguments)))) + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-revision-buffer)) + (setq magit--update-revision-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-show-commit rev args)))) + (setq magit--update-revision-buffer nil))))))) + +(defvar magit--update-blob-buffer nil) + +(defun magit-log-maybe-update-blob-buffer (&optional _) + "When moving in a log or cherry buffer, update the blob buffer. +If there is no blob buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-log-mode 'magit-cherry-mode 'magit-reflog-mode) + (magit--maybe-update-blob-buffer))) + +(defun magit--maybe-update-blob-buffer () + (when-let* ((commit (magit-section-value-if 'commit)) + (buffer (seq-find (##with-current-buffer % + (eq revert-buffer-function + 'magit-revert-rev-file-buffer)) + (mapcar #'window-buffer (window-list))))) + (if magit--update-blob-buffer + (setq magit--update-blob-buffer (list commit buffer)) + (setq magit--update-blob-buffer (list commit buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (lambda () + (pcase-let ((`(,rev ,buf) magit--update-blob-buffer)) + (setq magit--update-blob-buffer nil) + (when (buffer-live-p buf) + (with-selected-window (get-buffer-window buf) + (with-current-buffer buf + (save-excursion + (magit-blob-visit (list (magit-rev-parse rev) + (magit-file-relative-name + magit-buffer-file-name))))))))))))) + +(defun magit-log-goto-commit-section (rev) + (let ((abbrev (magit-rev-format "%h" rev))) + (when-let ((section (seq-find (##equal (oref % value) abbrev) + (oref magit-root-section children)))) + (goto-char (oref section start))))) + +(defun magit-log-goto-same-commit () + (when (and magit-previous-section + (magit-section-match '(commit branch) + magit-previous-section)) + (magit-log-goto-commit-section (oref magit-previous-section value)))) + +;;; Log Margin + +(defvar-local magit-log-margin-show-shortstat nil) + +(transient-define-suffix magit-toggle-log-margin-style () + "Toggle between the regular and the shortstat margin style. +The shortstat style is experimental and rather slow." + :description "Toggle shortstat" + :key "x" + :transient t + (interactive) + (setq magit-log-margin-show-shortstat + (not magit-log-margin-show-shortstat)) + (magit-set-buffer-margin nil t)) + +(defun magit-log-format-margin (rev author date) + (when (magit-margin-option) + (if magit-log-margin-show-shortstat + (magit-log-format-shortstat-margin rev) + (magit-log-format-author-margin author date)))) + +(defun magit-log-format-author-margin (author date) + (pcase-let ((`(,_ ,style ,width ,details ,details-width) + (or magit-buffer-margin + (symbol-value (magit-margin-option)) + (error "No margin format specified for %s" major-mode)))) + (magit-make-margin-overlay + (concat (and details + (concat (magit--propertize-face + (truncate-string-to-width + (or author "") + details-width + nil ?\s + (magit--ellipsis 'margin)) + 'magit-log-author) + " ")) + (magit--propertize-face + (if (stringp style) + (format-time-string + style + (seconds-to-time (string-to-number date))) + (pcase-let* ((abbr (eq style 'age-abbreviated)) + (`(,cnt ,unit) (magit--age date abbr))) + (format (format (if abbr "%%2d%%-%dc" "%%2d %%-%ds") + (- width (if details (1+ details-width) 0))) + cnt unit))) + 'magit-log-date))))) + +(defun magit-log-format-shortstat-margin (rev) + (magit-make-margin-overlay + (if-let ((line (and rev (magit-git-string + "show" "--format=" "--shortstat" rev)))) + (if (string-match "\ +\\([0-9]+\\) files? changed, \ +\\(?:\\([0-9]+\\) insertions?(\\+)\\)?\ +\\(?:\\(?:, \\)?\\([0-9]+\\) deletions?(-)\\)?\\'" line) + (magit-bind-match-strings (files add del) line + (format + "%5s %5s%4s" + (if add + (magit--propertize-face (format "%s+" add) + 'magit-diffstat-added) + "") + (if del + (magit--propertize-face (format "%s-" del) + 'magit-diffstat-removed) + "") + files)) + "") + ""))) + +(defun magit-log-margin-width (style details details-width) + (if magit-log-margin-show-shortstat + 16 + (+ (if details (1+ details-width) 0) + (if (stringp style) + (length (format-time-string style)) + (+ 2 ; two digits + 1 ; trailing space + (if (eq style 'age-abbreviated) + 1 ; single character + (+ 1 ; gap after digits + (apply #'max (mapcar (##max (length (nth 1 %)) + (length (nth 2 %))) + magit--age-spec))))))))) + +;;; Select Mode + +(defvar-keymap magit-log-select-mode-map + :doc "Keymap for `magit-log-select-mode'." + :parent magit-log-mode-map + "C-c C-b" #'undefined + "C-c C-f" #'undefined + "." #'magit-log-select-pick + "e" #'magit-log-select-pick + "C-c C-c" #'magit-log-select-pick + "q" #'magit-log-select-quit + "C-c C-k" #'magit-log-select-quit) +(put 'magit-log-select-pick :advertised-binding [?\C-c ?\C-c]) +(put 'magit-log-select-quit :advertised-binding [?\C-c ?\C-k]) + +(define-derived-mode magit-log-select-mode magit-log-mode "Magit Select" + "Mode for selecting a commit from history. + +This mode is documented in info node `(magit)Select from Log'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +\\\ +Type \\[magit-log-select-pick] to select the commit at point. +Type \\[magit-log-select-quit] to abort without selecting a commit." + :group 'magit-log + (magit-hack-dir-local-variables)) + +(put 'magit-log-select-mode 'magit-log-default-arguments + '("--graph" "-n256" "--decorate")) + +(defun magit-log-select-setup-buffer (revs args) + (magit-setup-buffer #'magit-log-select-mode nil + (magit-buffer-revisions revs) + (magit-buffer-log-args args))) + +(defun magit-log-select-refresh-buffer () + (setq magit-section-inhibit-markers t) + (setq magit-section-insert-in-reverse t) + (magit-insert-section (logbuf) + (magit--insert-log t magit-buffer-revisions + (magit-log--maybe-drop-color-graph + magit-buffer-log-args + (magit-log-get-commit-limit))))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-log-select-mode)) + magit-buffer-revisions) + +(defvar-local magit-log-select-pick-function nil) +(defvar-local magit-log-select-quit-function nil) + +(defun magit-log-select (pick &optional msg quit branch args initial) + (declare (indent defun)) + (unless initial + (setq initial (magit-commit-at-point))) + (magit-log-select-setup-buffer + (or branch (magit-get-current-branch) "HEAD") + (append args + (car (magit-log--get-value 'magit-log-select-mode + magit-direct-use-buffer-arguments)))) + (if initial + (magit-log-goto-commit-section initial) + (while-let ((rev (magit-section-value-if 'commit)) + ((string-match-p "\\`\\(squash!\\|fixup!\\|amend!\\)" + (magit-rev-format "%s" rev))) + (section (magit-current-section)) + (next (car (magit-section-siblings section 'next)))) + (magit-section-goto next))) + (setq magit-log-select-pick-function pick) + (setq magit-log-select-quit-function quit) + (when magit-log-select-show-usage + (let ((pick (propertize (substitute-command-keys + "\\[magit-log-select-pick]") + 'font-lock-face + 'magit-header-line-key)) + (quit (propertize (substitute-command-keys + "\\[magit-log-select-quit]") + 'font-lock-face + 'magit-header-line-key))) + (setq msg (format-spec + (if msg + (if (string-suffix-p "," msg) + (concat msg " or %q to abort") + msg) + "Type %p to select commit at point, or %q to abort") + `((?p . ,pick) + (?q . ,quit))))) + (magit--add-face-text-property + 0 (length msg) 'magit-header-line-log-select t msg) + (when (memq magit-log-select-show-usage '(both header-line)) + (magit-set-header-line-format msg)) + (when (memq magit-log-select-show-usage '(both echo-area)) + (message "%s" (substring-no-properties msg))))) + +(defun magit-log-select-pick () + "Select the commit at point and act on it. +Call `magit-log-select-pick-function' with the selected +commit as argument." + (interactive) + (let ((fun magit-log-select-pick-function) + (rev (magit-commit-at-point))) + (magit-mode-bury-buffer 'kill) + (funcall fun rev))) + +(defun magit-log-select-quit () + "Abort selecting a commit, don't act on any commit. +Call `magit-log-select-quit-function' if set." + (interactive) + (let ((fun magit-log-select-quit-function)) + (magit-mode-bury-buffer 'kill) + (when fun (funcall fun)))) + +;;; Cherry Mode + +(defvar-keymap magit-cherry-mode-map + :doc "Keymap for `magit-cherry-mode'." + :parent magit-mode-map + "q" #'magit-log-bury-buffer + "L" #'magit-margin-settings) + +(define-derived-mode magit-cherry-mode magit-mode "Magit Cherry" + "Mode for looking at commits not merged upstream. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-cherry-pick] to apply the commit at point. + +\\{magit-cherry-mode-map}" + :interactive nil + :group 'magit-log + (magit-hack-dir-local-variables) + (setq magit--imenu-group-types 'cherries)) + +(defun magit-cherry-setup-buffer (head upstream) + (magit-setup-buffer #'magit-cherry-mode nil + (magit-buffer-refname head) + (magit-buffer-upstream upstream) + (magit-buffer-range (concat upstream ".." head)))) + +(defun magit-cherry-refresh-buffer () + (setq magit-section-insert-in-reverse t) + (magit-insert-section (cherry) + (magit-run-section-hook 'magit-cherry-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-cherry-mode)) + magit-buffer-range) + +;;;###autoload +(defun magit-cherry (head upstream) + "Show commits in a branch that are not merged in the upstream branch." + (interactive + (let ((head (magit-read-branch "Cherry head"))) + (list head (magit-read-other-branch "Cherry upstream" head + (magit-get-upstream-branch head))))) + (require 'magit) + (magit-cherry-setup-buffer head upstream)) + +(defun magit-insert-cherry-headers () + "Insert headers appropriate for `magit-cherry-mode' buffers." + (let ((branch (propertize magit-buffer-refname + 'font-lock-face 'magit-branch-local)) + (upstream (propertize magit-buffer-upstream 'font-lock-face + (if (magit-local-branch-p magit-buffer-upstream) + 'magit-branch-local + 'magit-branch-remote)))) + (magit-insert-head-branch-header branch) + (magit-insert-upstream-branch-header branch upstream "Upstream: ") + (insert ?\n))) + +(defun magit-insert-cherry-commits () + "Insert commit sections into a `magit-cherry-mode' buffer." + (magit-insert-section (cherries) + (magit-insert-heading t "Cherry commits") + (magit-git-wash (apply-partially #'magit-log-wash-log 'cherry) + "cherry" "-v" "--abbrev" + magit-buffer-upstream + magit-buffer-refname))) + +;;; Log Sections +;;;; Standard Log Sections + +(defvar-keymap magit-log-section-map + :doc "Keymap for log sections. +The classes `magit-{unpulled,unpushed,unmerged}-section' derive +from the abstract `magit-log-section' class. Accordingly this +keymap is the parent of their keymaps." + " " #'magit-diff-dwim + "<1>" (magit-menu-item "Visit diff" #'magit-diff-dwim)) + +(cl-defmethod magit-section-ident-value ((section magit-unpulled-section)) + "Return \"..@{push}\". +\"..@{push}\" cannot be used as the value because that is ambiguous +if `push.default' does not allow a 1:1 mapping, and many commands +would fail because of that. But here that does not matter and we +need an unique value, so we use that string in the pushremote case." + (let ((value (oref section value))) + (if (equal value "..@{upstream}") value "..@{push}"))) + +(magit-define-section-jumper magit-jump-to-unpulled-from-upstream + "Unpulled from @{upstream}" unpulled "..@{upstream}" + magit-insert-unpulled-from-upstream) + +(defun magit-insert-unpulled-from-upstream () + "Insert commits that haven't been pulled from the upstream yet." + (when-let ((upstream (magit-get-upstream-branch))) + (magit-insert-section (unpulled "..@{upstream}" t) + (magit-insert-heading + (format (propertize "Unpulled from %s." + 'font-lock-face 'magit-section-heading) + upstream)) + (magit--insert-log nil "..@{upstream}" magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(magit-define-section-jumper magit-jump-to-unpulled-from-pushremote + "Unpulled from " unpulled "..@{push}" + magit-insert-unpulled-from-pushremote) + +(defun magit-insert-unpulled-from-pushremote () + "Insert commits that haven't been pulled from the push-remote yet." + (when-let* ((target (magit-get-push-branch)) + (range (concat ".." target)) + ((magit--insert-pushremote-log-p))) + (magit-insert-section (unpulled range t) + (magit-insert-heading + (format (propertize "Unpulled from %s." + 'font-lock-face 'magit-section-heading) + (propertize target 'font-lock-face 'magit-branch-remote))) + (magit--insert-log nil range magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(cl-defmethod magit-section-ident-value ((section magit-unpushed-section)) + "Return \"..@{push}\". +\"..@{push}\" cannot be used as the value because that is ambiguous +if `push.default' does not allow a 1:1 mapping, and many commands +would fail because of that. But here that does not matter and we +need an unique value, so we use that string in the pushremote case." + (let ((value (oref section value))) + (if (equal value "@{upstream}..") value "@{push}.."))) + +(magit-define-section-jumper magit-jump-to-unpushed-to-upstream + "Unpushed to @{upstream}" unpushed "@{upstream}.." nil + :if (lambda () + (or (memq 'magit-insert-unpushed-to-upstream-or-recent + magit-status-sections-hook) + (memq 'magit-insert-unpushed-to-upstream + magit-status-sections-hook))) + :description (lambda () + (let ((upstream (magit-get-upstream-branch))) + (if (or (not upstream) + (magit-rev-ancestor-p "HEAD" upstream)) + "Recent commits" + "Unmerged into upstream")))) + +(defun magit-insert-unpushed-to-upstream-or-recent () + "Insert section showing unpushed or other recent commits. +If an upstream is configured for the current branch and it is +behind of the current branch, then show the commits that have +not yet been pushed into the upstream branch. If no upstream is +configured or if the upstream is not behind of the current branch, +then show the last `magit-log-section-commit-count' commits." + (let ((upstream (magit-get-upstream-branch))) + (if (or (not upstream) + (magit-rev-ancestor-p "HEAD" upstream)) + (magit-insert-recent-commits 'unpushed "@{upstream}..") + (magit-insert-unpushed-to-upstream)))) + +(defun magit-insert-unpushed-to-upstream () + "Insert commits that haven't been pushed to the upstream yet." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpushed "@{upstream}..") + (magit-insert-heading + (format (propertize "Unmerged into %s." + 'font-lock-face 'magit-section-heading) + (magit-get-upstream-branch))) + (magit--insert-log nil "@{upstream}.." magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(defun magit-insert-recent-commits (&optional type value) + "Insert section showing recent commits. +Show the last `magit-log-section-commit-count' commits." + (let* ((start (format "HEAD~%s" magit-log-section-commit-count)) + (range (and (magit-rev-verify start) + (concat start "..HEAD")))) + (magit-insert-section ((eval (or type 'recent)) + (or value range) + t) + (magit-insert-heading "Recent commits") + (magit--insert-log nil + (and (member "--graph" magit-buffer-log-args) range) + (cons (format "-n%d" magit-log-section-commit-count) + (seq-remove (##string-prefix-p "-n" %) + magit-buffer-log-args)))))) + +(magit-define-section-jumper magit-jump-to-unpushed-to-pushremote + "Unpushed to " unpushed "@{push}.." + magit-insert-unpushed-to-pushremote) + +(defun magit-insert-unpushed-to-pushremote () + "Insert commits that haven't been pushed to the push-remote yet." + (when-let* ((target (magit-get-push-branch)) + (range (concat target "..")) + ((magit--insert-pushremote-log-p))) + (magit-insert-section (unpushed range t) + (magit-insert-heading + (format (propertize "Unpushed to %s." + 'font-lock-face 'magit-section-heading) + (propertize target 'font-lock-face 'magit-branch-remote))) + (magit--insert-log nil range magit-buffer-log-args) + (magit-log-insert-child-count)))) + +(defun magit--insert-pushremote-log-p () + (magit--with-refresh-cache + (cons default-directory 'magit--insert-pushremote-log-p) + (not (and (equal (magit-get-push-branch) + (magit-get-upstream-branch)) + (or (memq 'magit-insert-unpulled-from-upstream + magit-status-sections-hook) + (memq 'magit-insert-unpulled-from-upstream-or-recent + magit-status-sections-hook)))))) + +(defun magit-log-insert-child-count () + (when magit-section-show-child-count + (let ((count (length (oref magit-insert-section--current children)))) + (when (> count 0) + (when (eq count (magit-log-get-commit-limit)) + (setq count (format "%s+" count))) + (save-excursion + (goto-char (- (oref magit-insert-section--current content) 2)) + (insert (format " (%s)" count)) + (delete-char 1)))))) + +;;;; Auxiliary Log Sections + +(defun magit-insert-unpulled-cherries () + "Insert section showing unpulled commits. +Like `magit-insert-unpulled-from-upstream' but prefix each commit +which has not been applied yet (i.e., a commit with a patch-id +not shared with any local commit) with \"+\", and all others with +\"-\"." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpulled "..@{upstream}") + (magit-insert-heading t "Unpulled commits") + (magit-git-wash (apply-partially #'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) + (magit-get-current-branch) "@{upstream}")))) + +(defun magit-insert-unpushed-cherries () + "Insert section showing unpushed commits. +Like `magit-insert-unpushed-to-upstream' but prefix each commit +which has not been applied to upstream yet (i.e., a commit with +a patch-id not shared with any upstream commit) with \"+\", and +all others with \"-\"." + (when (magit-git-success "rev-parse" "@{upstream}") + (magit-insert-section (unpushed "@{upstream}..") + (magit-insert-heading t "Unpushed commits") + (magit-git-wash (apply-partially #'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) "@{upstream}")))) + +;;; _ +(provide 'magit-log) +;;; magit-log.el ends here blob - /dev/null blob + b710fbddd398fe4ce8a3789e1af5086e603eeb2b (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-margin.el @@ -0,0 +1,253 @@ +;;; magit-margin.el --- Margins in Magit buffers -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for showing additional information +;; in the margins of Magit buffers. Currently this is only used for +;; commits, for which the committer date or age, and optionally the +;; author name are shown. + +;;; Code: + +(require 'magit-base) +(require 'magit-transient) +(require 'magit-mode) + +;;; Options + +(defgroup magit-margin nil + "Information Magit displays in the margin. + +You can change the STYLE and AUTHOR-WIDTH of all `magit-*-margin' +options to the same values by customizing `magit-log-margin' +*before* `magit' is loaded. If you do that, then the respective +values for the other options will default to what you have set +for that variable. Likewise if you set `magit-log-margin's INIT +to nil, then that is used in the default of all other options. But +setting it to t, i.e., re-enforcing the default for that option, +does not carry to other options." + :link '(info-link "(magit)Log Margin") + :group 'magit-log) + +(defvar-local magit-buffer-margin nil) +(put 'magit-buffer-margin 'permanent-local t) + +(defvar-local magit-set-buffer-margin-refresh nil) + +(defvar magit--age-spec) + +;;; Commands + +(transient-define-prefix magit-margin-settings () + "Change what information is displayed in the margin." + :info-manual "(magit) Log Margin" + ["Margin" + (magit-toggle-margin) + (magit-cycle-margin-style) + (magit-toggle-margin-details) + (magit-refs-set-show-commit-count)]) + +(transient-define-suffix magit-toggle-margin () + "Show or hide the Magit margin." + :description "Toggle visibility" + :key "L" + :transient t + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + (setcar magit-buffer-margin (not (magit-buffer-margin-p))) + (magit-set-buffer-margin)) + +(defvar magit-margin-default-time-format nil + "See https://github.com/magit/magit/pull/4605.") + +(transient-define-suffix magit-cycle-margin-style () + "Cycle style used for the Magit margin." + :description "Cycle style" + :key "l" + :transient t + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + ;; This is only suitable for commit margins (there are not others). + (setf (cadr magit-buffer-margin) + (pcase (cadr magit-buffer-margin) + ('age 'age-abbreviated) + ('age-abbreviated + (let ((default (or magit-margin-default-time-format + (cadr (symbol-value (magit-margin-option)))))) + (if (stringp default) default "%Y-%m-%d %H:%M "))) + (_ 'age))) + (magit-set-buffer-margin nil t)) + +(transient-define-suffix magit-toggle-margin-details () + "Show or hide details in the Magit margin." + :description "Toggle details" + :key "d" + :transient t + (interactive) + (unless (magit-margin-option) + (user-error "Magit margin isn't supported in this buffer")) + (setf (nth 3 magit-buffer-margin) + (not (nth 3 magit-buffer-margin))) + (magit-set-buffer-margin nil t)) + +;;; Core + +(defun magit-buffer-margin-p () + (car magit-buffer-margin)) + +(defun magit-margin-option () + (pcase major-mode + ('magit-cherry-mode 'magit-cherry-margin) + ('magit-log-mode 'magit-log-margin) + ('magit-log-select-mode 'magit-log-select-margin) + ('magit-reflog-mode 'magit-reflog-margin) + ('magit-refs-mode 'magit-refs-margin) + ('magit-stashes-mode 'magit-stashes-margin) + ('magit-status-mode 'magit-status-margin) + ('forge-notifications-mode 'magit-status-margin) + ('forge-topics-mode 'magit-status-margin))) + +(defun magit-set-buffer-margin (&optional reset refresh) + (when-let ((option (magit-margin-option))) + (let* ((default (symbol-value option)) + (default-width (nth 2 default))) + (when (or reset (not magit-buffer-margin)) + (setq magit-buffer-margin (copy-sequence default))) + (pcase-let ((`(,enable ,style ,_width ,details ,details-width) + magit-buffer-margin)) + (when (functionp default-width) + (setf (nth 2 magit-buffer-margin) + (funcall default-width style details details-width))) + (dolist (window (get-buffer-window-list nil nil 0)) + (with-selected-window window + (magit-set-window-margin window) + (if enable + (add-hook 'window-configuration-change-hook + #'magit-set-window-margin nil t) + (remove-hook 'window-configuration-change-hook + #'magit-set-window-margin t)))) + (when (and enable (or refresh magit-set-buffer-margin-refresh)) + (magit-refresh-buffer)))))) + +(defun magit-set-window-margin (&optional window) + (when (or window (setq window (get-buffer-window))) + (with-selected-window window + (set-window-margins + nil (car (window-margins)) + (and (magit-buffer-margin-p) + (nth 2 magit-buffer-margin)))))) + +(cl-defun magit-make-margin-overlay (&optional string (previous-line nil sline)) + "Display STRING in the margin of the previous (or current) line. +If point is at the beginning of a line, set the margin string for +the previous line, otherwise for the current line. Semi-obsolete +optional PREVIOUS-LINE can be used to explicitly specify which +line is affected." + (save-excursion + (forward-line (if (if sline previous-line (bolp)) -1 0)) + ;; Don't put the overlay on the complete line to work around #1880. + (let ((o (make-overlay (1+ (point)) (line-end-position) nil t))) + (overlay-put o 'evaporate t) + (overlay-put o 'before-string + (propertize "o" 'display + (list (list 'margin 'right-margin) + (or string " "))))))) + +(defvar magit-margin-overlay-conditions + '( unpulled unpushed recent stashes local cherries + [remote branchbuf] + [shelved branchbuf] + [tags branchbuf] + topics issues pullreqs)) + +(defun magit-maybe-make-margin-overlay () + (when (magit-section-match magit-margin-overlay-conditions + magit-insert-section--current) + (magit-make-margin-overlay))) + +;;; Custom Support + +(defun magit-margin-set-variable (mode symbol value) + (set-default symbol value) + (message "Updating margins in %s buffers..." mode) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (eq major-mode mode) + (magit-set-buffer-margin t) + (magit-refresh)))) + (message "Updating margins in %s buffers...done" mode)) + +(defconst magit-log-margin--custom-type + '(list (boolean :tag "Show margin initially") + (choice :tag "Show committer" + (string :tag "date using time-format" "%Y-%m-%d %H:%M ") + (const :tag "date's age" age) + (const :tag "date's age (abbreviated)" age-abbreviated)) + (const :tag "Calculate width using magit-log-margin-width" + magit-log-margin-width) + (boolean :tag "Show author name by default") + (integer :tag "Show author name using width"))) + +;;; Time Utilities + +(defvar magit--age-spec + `((?Y "year" "years" ,(round (* 60 60 24 365.2425))) + (?M "month" "months" ,(round (* 60 60 24 30.436875))) + (?w "week" "weeks" ,(* 60 60 24 7)) + (?d "day" "days" ,(* 60 60 24)) + (?h "hour" "hours" ,(* 60 60)) + (?m "minute" "minutes" 60) + (?s "second" "seconds" 1)) + "Time units used when formatting relative commit ages. + +The value is a list of time units, beginning with the longest. +Each element has the form (CHAR UNIT UNITS SECONDS). UNIT is the +time unit, UNITS is the plural of that unit. CHAR is a character +abbreviation. And SECONDS is the number of seconds in one UNIT. + +This is defined as a variable to make it possible to use time +units for a language other than English. It is not defined +as an option, because most other parts of Magit are always in +English.") + +(defun magit--age (date &optional abbreviate) + (cl-labels ((fn (age spec) + (pcase-let ((`(,char ,unit ,units ,weight) (car spec))) + (let ((cnt (round (/ age weight 1.0)))) + (if (or (not (cdr spec)) + (>= (/ age weight) 1)) + (list cnt (cond (abbreviate char) + ((= cnt 1) unit) + (t units))) + (fn age (cdr spec))))))) + (fn (abs (- (float-time) + (if (stringp date) + (string-to-number date) + date))) + magit--age-spec))) + +;;; _ +(provide 'magit-margin) +;;; magit-margin.el ends here blob - /dev/null blob + 4dc003ff628e4ee3add6003dfa77978cac93e09d (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-merge.el @@ -0,0 +1,315 @@ +;;; magit-merge.el --- Merge functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements merge commands. + +;;; Code: + +(require 'magit) +(require 'magit-diff) + +(declare-function magit-git-push "magit-push" (branch target args)) + +;;; Commands + +;;;###autoload (autoload 'magit-merge "magit" nil t) +(transient-define-prefix magit-merge () + "Merge branches." + :man-page "git-merge" + :incompatible '(("--ff-only" "--no-ff")) + ["Arguments" + :if-not magit-merge-in-progress-p + ("-f" "Fast-forward only" "--ff-only") + ("-n" "No fast-forward" "--no-ff") + (magit-merge:--strategy) + (5 magit-merge:--strategy-option) + (5 "-b" "Ignore changes in amount of whitespace" "-Xignore-space-change") + (5 "-w" "Ignore whitespace when comparing lines" "-Xignore-all-space") + (5 magit-diff:--diff-algorithm :argument "-Xdiff-algorithm=") + (magit:--gpg-sign) + (magit:--signoff)] + ["Actions" + :if-not magit-merge-in-progress-p + [("m" "Merge" magit-merge-plain) + ("e" "Merge and edit message" magit-merge-editmsg) + ("n" "Merge but don't commit" magit-merge-nocommit) + ("a" "Absorb" magit-merge-absorb)] + [("p" "Preview merge" magit-merge-preview) + "" + ("s" "Squash merge" magit-merge-squash) + ("d" "Dissolve" magit-merge-dissolve)]] + ["Actions" + :if magit-merge-in-progress-p + ("m" "Commit merge" magit-commit-create) + ("a" "Abort merge" magit-merge-abort)]) + +(defun magit-merge-arguments () + (transient-args 'magit-merge)) + +(transient-define-argument magit-merge:--strategy () + :description "Strategy" + :class 'transient-option + ;; key for merge and rebase: "-s" + ;; key for cherry-pick and revert: "=s" + ;; shortarg for merge and rebase: "-s" + ;; shortarg for cherry-pick and revert: none + :key "-s" + :argument "--strategy=" + :choices '("resolve" "recursive" "octopus" "ours" "subtree")) + +(transient-define-argument magit-merge:--strategy-option () + :description "Strategy Option" + :class 'transient-option + :key "-X" + :argument "--strategy-option=" + :choices '("ours" "theirs" "patience")) + +;;;###autoload +(defun magit-merge-plain (rev &optional args nocommit) + "Merge commit REV into the current branch; using default message. + +Unless there are conflicts or a prefix argument is used create a +merge commit using a generic commit message and without letting +the user inspect the result. With a prefix argument pretend the +merge failed to give the user the opportunity to inspect the +merge. + +\(git merge --no-edit|--no-commit [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments) + current-prefix-arg)) + (magit-merge-assert) + (magit-run-git-async "merge" (if nocommit "--no-commit" "--no-edit") args rev)) + +;;;###autoload +(defun magit-merge-editmsg (rev &optional args) + "Merge commit REV into the current branch; and edit message. +Perform the merge and prepare a commit message but let the user +edit it. +\n(git merge --edit --no-ff [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments))) + (magit-merge-assert) + (cl-pushnew "--no-ff" args :test #'equal) + (apply #'magit-run-git-with-editor "merge" "--edit" + (append (delete "--ff-only" args) + (list rev)))) + +;;;###autoload +(defun magit-merge-nocommit (rev &optional args) + "Merge commit REV into the current branch; pretending it failed. +Pretend the merge failed to give the user the opportunity to +inspect the merge and change the commit message. +\n(git merge --no-commit --no-ff [ARGS] REV)" + (interactive (list (magit-read-other-branch-or-commit "Merge") + (magit-merge-arguments))) + (magit-merge-assert) + (cl-pushnew "--no-ff" args :test #'equal) + (magit-run-git-async "merge" "--no-commit" args rev)) + +;;;###autoload +(defun magit-merge-dissolve (branch &optional args) + "Merge the current branch into BRANCH and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch." + (interactive + (list (let ((branch (magit-get-current-branch))) + (magit-read-other-local-branch + (format "Merge `%s' into" (or branch (magit-rev-parse "HEAD"))) + nil + (and branch (magit-get-local-upstream-branch branch)))) + (magit-merge-arguments))) + (let ((current (magit-get-current-branch)) + (head (magit-rev-parse "HEAD"))) + (when (zerop (magit-call-git "checkout" branch)) + (if current + (magit--merge-absorb current args) + (magit-run-git-with-editor "merge" args head))))) + +;;;###autoload +(defun magit-merge-absorb (branch &optional args) + "Merge BRANCH into the current branch and remove the former. + +Before merging, force push the source branch to its push-remote, +provided the respective remote branch already exists, ensuring +that the respective pull-request (if any) won't get stuck on some +obsolete version of the commits that are being merged. Finally +if `forge-branch-pullreq' was used to create the merged branch, +then also remove the respective remote branch." + (interactive (list (magit-read-other-local-branch "Absorb branch") + (magit-merge-arguments))) + (magit--merge-absorb branch args)) + +(defun magit--merge-absorb (branch args &optional message) + (when (equal branch (magit-main-branch)) + (unless (yes-or-no-p + (format "Do you really want to merge `%s' into another branch? " + branch)) + (user-error "Abort"))) + (if-let ((target (magit-get-push-branch branch t))) + (progn + (magit-git-push branch target (list "--force-with-lease")) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (not (zerop (process-exit-status process))) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit--merge-absorb-1 branch args)) + (when message + (message message)))))) + (magit--merge-absorb-1 branch args))) + +(defun magit--merge-absorb-1 (branch args) + (if-let ((pr (magit-get "branch" branch "pullRequest"))) + (magit-run-git-async + "merge" args "-m" + (format "Merge branch '%s'%s [#%s]" + branch + (let ((current (magit-get-current-branch))) + (if (equal current (magit-main-branch)) + "" + (format " into %s" current))) + pr) + branch) + (magit-run-git-async "merge" args "--no-edit" branch)) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-branch-maybe-delete-pr-remote branch) + (magit-branch-unset-pushRemote branch) + (magit-run-git "branch" "-D" branch)))))) + +;;;###autoload +(defun magit-merge-squash (rev) + "Squash commit REV into the current branch; don't create a commit. +\n(git merge --squash REV)" + (interactive (list (magit-read-other-branch-or-commit "Squash"))) + (magit-merge-assert) + (magit-run-git-async "merge" "--squash" rev)) + +;;;###autoload +(defun magit-merge-preview (rev) + "Preview result of merging REV into the current branch." + (interactive (list (magit-read-other-branch-or-commit "Preview merge"))) + (magit-merge-preview-setup-buffer rev)) + +;;;###autoload +(defun magit-merge-abort () + "Abort the current merge operation. +\n(git merge --abort)" + (interactive) + (unless (file-exists-p (expand-file-name "MERGE_HEAD" (magit-gitdir))) + (user-error "No merge in progress")) + (magit-confirm 'abort-merge) + (magit-run-git-async "merge" "--abort")) + +(defun magit-checkout-stage (file arg) + "During a conflict checkout and stage side, or restore conflict." + (interactive + (let ((file (magit-completing-read "Checkout file" + (magit-tracked-files) nil nil nil + 'magit-read-file-hist + (magit-current-file)))) + (cond ((member file (magit-unmerged-files)) + (list file (magit-checkout-read-stage file))) + ((yes-or-no-p (format "Restore conflicts in %s? " file)) + (list file "--merge")) + (t + (user-error "Quit"))))) + (pcase (cons arg (cddr (car (magit-file-status file)))) + ((or `("--ours" ?D ,_) + '("--ours" ?U ?A) + `("--theirs" ,_ ?D) + '("--theirs" ?A ?U)) + (magit-run-git "rm" "--" file)) + (_ (if (equal arg "--merge") + ;; This fails if the file was deleted on one + ;; side. And we cannot do anything about it. + (magit-run-git "checkout" "--merge" "--" file) + (magit-call-git "checkout" arg "--" file) + (magit-run-git "add" "-u" "--" file))))) + +;;; Utilities + +(defun magit-merge-in-progress-p () + (file-exists-p (expand-file-name "MERGE_HEAD" (magit-gitdir)))) + +(defun magit--merge-range (&optional head) + (unless head + (setq head (magit-get-shortname + (car (magit-file-lines + (expand-file-name "MERGE_HEAD" (magit-gitdir))))))) + (and head + (concat (magit-git-string "merge-base" "--octopus" "HEAD" head) + ".." head))) + +(defun magit-merge-assert () + (or (not (magit-anything-modified-p t)) + (magit-confirm 'merge-dirty + "Merging with dirty worktree is risky. Continue"))) + +(defun magit-checkout-read-stage (file) + (magit-read-char-case (format "For %s checkout: " file) t + (?o "[o]ur stage" "--ours") + (?t "[t]heir stage" "--theirs") + (?c (if magit-verbose-messages "restore [c]onflict" "[c]onflict") + "--merge"))) + +;;; Sections + +(defun magit-insert-merge-log () + "Insert section for the on-going merge. +Display the heads that are being merged. +If no merge is in progress, do nothing." + (when (magit-merge-in-progress-p) + (let* ((heads (mapcar #'magit-get-shortname + (magit-file-lines + (expand-file-name "MERGE_HEAD" (magit-gitdir))))) + (range (magit--merge-range (car heads)))) + (magit-insert-section (unmerged range) + (magit-insert-heading + (format "Merging %s:" (string-join heads ", "))) + (magit--insert-log nil + range + (let ((args magit-buffer-log-args)) + (unless (member "--decorate=full" magit-buffer-log-args) + (push "--decorate=full" args)) + args)))))) + +;;; _ +(provide 'magit-merge) +;;; magit-merge.el ends here blob - /dev/null blob + a90b1dabe114c1a93ad485cb9ae5ad3ad9bd49c8 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-mode.el @@ -0,0 +1,1572 @@ +;;; magit-mode.el --- Create and refresh Magit buffers -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements the abstract major-mode `magit-mode' from +;; which almost all other Magit major-modes derive. The code in here +;; is mostly concerned with creating and refreshing Magit buffers. + +;;; Code: + +(require 'magit-base) +(require 'magit-git) + +(require 'benchmark) +(require 'browse-url) +(require 'format-spec) +(require 'help-mode) + +(require 'transient) + +(defvar bookmark-make-record-function) + +(eval-when-compile (require 'elp)) +(declare-function elp-reset-all "elp" ()) +(declare-function elp-instrument-package "elp" (prefix)) +(declare-function elp-results "elp" ()) +(declare-function elp-restore-all "elp" ()) + +(defvar magit--wip-inhibit-autosave) +(defvar magit-wip-after-save-local-mode) +(declare-function magit-wip-get-ref "magit-wip" ()) +(declare-function magit-wip-commit-worktree "magit-wip" (ref files msg)) + +;;; Options + +(defcustom magit-mode-hook + (list #'magit-load-config-extensions) + "Hook run when entering a mode derived from Magit mode." + :package-version '(magit . "3.0.0") + :group 'magit-modes + :type 'hook + :options (list #'magit-load-config-extensions + #'bug-reference-mode)) + +(defcustom magit-setup-buffer-hook + (list #'magit-maybe-save-repository-buffers + 'magit-set-buffer-margin) ; from magit-margin.el + "Hook run by `magit-setup-buffer'. + +This is run right after displaying the buffer and right before +generating or updating its content. `magit-mode-hook' and other, +more specific, `magit-mode-*-hook's on the other hand are run +right before displaying the buffer. Usually one of these hooks +should be used instead of this one." + :package-version '(magit . "2.3.0") + :group 'magit-modes + :type 'hook + :options (list #'magit-maybe-save-repository-buffers + 'magit-set-buffer-margin)) + +(defcustom magit-pre-refresh-hook + (list #'magit-maybe-save-repository-buffers) + "Hook run before refreshing in `magit-refresh'. + +This hook, or `magit-post-refresh-hook', should be used +for functions that are not tied to a particular buffer. + +To run a function with a particular buffer current, use +`magit-refresh-buffer-hook' and use `derived-mode-p' +inside your function." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :type 'hook + :options (list #'magit-maybe-save-repository-buffers)) + +(defcustom magit-post-refresh-hook + ;; Do not function-quote to avoid circular dependencies. + '(magit-auto-revert-buffers + magit-run-post-commit-hook + magit-run-post-stage-hook + magit-run-post-unstage-hook) + "Hook run after refreshing in `magit-refresh'. + +This hook, or `magit-pre-refresh-hook', should be used +for functions that are not tied to a particular buffer. + +To run a function with a particular buffer current, use +`magit-refresh-buffer-hook' and use `derived-mode-p' +inside your function." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :type 'hook + :options '(magit-auto-revert-buffers + magit-run-post-commit-hook + magit-run-post-stage-hook + magit-run-post-unstage-hook)) + +(defcustom magit-display-buffer-function #'magit-display-buffer-traditional + "The function used to display a Magit buffer. + +All Magit buffers (buffers whose major-modes derive from +`magit-mode') are displayed using `magit-display-buffer', +which in turn uses the function specified here." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type `(radio (function-item ,#'magit-display-buffer-traditional) + (function-item ,#'magit-display-buffer-same-window-except-diff-v1) + (function-item ,#'magit-display-buffer-fullframe-status-v1) + (function-item ,#'magit-display-buffer-fullframe-status-topleft-v1) + (function-item ,#'magit-display-buffer-fullcolumn-most-v1) + (function-item ,#'display-buffer) + (function :tag "Function"))) + +(defcustom magit-pre-display-buffer-hook + (list #'magit-save-window-configuration) + "Hook run by `magit-display-buffer' before displaying the buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'hook + :get #'magit-hook-custom-get + :options (list #'magit-save-window-configuration)) + +(defcustom magit-post-display-buffer-hook (list #'magit-maybe-set-dedicated) + "Hook run by `magit-display-buffer' after displaying the buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'hook + :get #'magit-hook-custom-get + :options (list #'magit-maybe-set-dedicated)) + +(defcustom magit-generate-buffer-name-function + #'magit-generate-buffer-name-default-function + "The function used to generate the name for a Magit buffer." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type `(radio (function-item ,#'magit-generate-buffer-name-default-function) + (function :tag "Function"))) + +(defcustom magit-buffer-name-format "%x%M%v: %t%x" + "The format string used to name Magit buffers. + +The following %-sequences are supported: + +`%m' The name of the major-mode, but with the `-mode' suffix + removed. + +`%M' Like \"%m\" but abbreviate `magit-status-mode' as `magit'. + +`%v' The value the buffer is locked to, in parentheses, or an + empty string if the buffer is not locked to a value. + +`%V' Like \"%v\", but the string is prefixed with a space, unless + it is an empty string. + +`%t' The top-level directory of the working tree of the + repository, or if `magit-uniquify-buffer-names' is non-nil + an abbreviation of that. + +`%x' If `magit-uniquify-buffer-names' is nil \"*\", otherwise the + empty string. Due to limitations of the `uniquify' package, + buffer names must end with the path. + +The value should always contain \"%m\" or \"%M\", \"%v\" or \"%V\", and +\"%t\". If `magit-uniquify-buffer-names' is non-nil, then the +value must end with \"%t\" or \"%t%x\". See issue #2841. + +This is used by `magit-generate-buffer-name-default-function'. +If another `magit-generate-buffer-name-function' is used, then +it may not respect this option, or on the contrary it may +support additional %-sequences." + :package-version '(magit . "2.12.0") + :group 'magit-buffers + :type 'string) + +(defcustom magit-uniquify-buffer-names t + "Whether to uniquify the names of Magit buffers." + :package-version '(magit . "2.3.0") + :group 'magit-buffers + :type 'boolean) + +(defcustom magit-bury-buffer-function #'magit-mode-quit-window + "The function used to bury or kill the current Magit buffer." + :package-version '(magit . "3.2.0") + :group 'magit-buffers + :type `(radio (function-item ,#'quit-window) + (function-item ,#'magit-mode-quit-window) + (function-item ,#'magit-restore-window-configuration) + (function :tag "Function"))) + +(defcustom magit-prefix-use-buffer-arguments 'selected + "Whether certain prefix commands reuse arguments active in relevant buffer. + +This affects the transient prefix commands `magit-diff', +`magit-log' and `magit-show-refs'. + +Valid values are: + +`always': Always use the set of arguments that is currently + active in the respective buffer, provided that buffer exists + of course. +`selected': Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default. +`current': Use the set of arguments from the respective buffer, + but only if it is the current buffer. +`never': Never use the set of arguments from the respective + buffer. + +For more information see info node `(magit)Transient Arguments +and Buffer Variables'." + :package-version '(magit . "3.0.0") + :group 'magit-buffers + :group 'magit-commands + :group 'magit-diff + :group 'magit-log + :type '(choice + (const :tag "Always use args from buffer" always) + (const :tag "Use args from buffer if displayed in frame" selected) + (const :tag "Use args from buffer if it is current" current) + (const :tag "Never use args from buffer" never))) + +(defcustom magit-direct-use-buffer-arguments 'selected + "Whether certain commands reuse arguments active in relevant buffer. + +This affects certain commands such as `magit-show-commit' that +are suffixes of the diff or log transient prefix commands, but +only if they are invoked directly, i.e., *not* as a suffix. + +Valid values are: + +`always': Always use the set of arguments that is currently + active in the respective buffer, provided that buffer exists + of course. +`selected': Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default. +`current': Use the set of arguments from the respective buffer, + but only if it is the current buffer. +`never': Never use the set of arguments from the respective + buffer. + +For more information see info node `(magit)Transient Arguments +and Buffer Variables'." + :package-version '(magit . "3.0.0") + :group 'magit-buffers + :group 'magit-commands + :group 'magit-diff + :group 'magit-log + :type '(choice + (const :tag "Always use args from buffer" always) + (const :tag "Use args from buffer if displayed in frame" selected) + (const :tag "Use args from buffer if it is current" current) + (const :tag "Never use args from buffer" never))) + +(defcustom magit-region-highlight-hook + '(magit-diff-update-hunk-region) ; from magit-diff.el + "Functions used to highlight the region. + +Each function is run with the current section as only argument +until one of them returns non-nil. If all functions return nil, +then fall back to regular region highlighting." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'hook + :options '(magit-diff-update-hunk-region)) + +(defcustom magit-create-buffer-hook nil + "Normal hook run while creating a new `magit-mode' buffer. +Runs before the buffer is populated with sections. Also see +`magit-post-create-buffer-hook'." + :package-version '(magit . "2.90.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-post-create-buffer-hook nil + "Normal hook run after creating a new `magit-mode' buffer. +Runs after the buffer is populated with sections for the first +time. Also see `magit-create-buffer-hook' (which runs earlier) +and `magit-refresh-buffer-hook' (which runs on every refresh)." + :package-version '(magit . "4.0.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-refresh-buffer-hook nil + "Normal hook for `magit-refresh-buffer' to run after refreshing." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'hook) + +(defcustom magit-refresh-status-buffer t + "Whether the status buffer is refreshed after running git. + +When this is non-nil, then the status buffer is automatically +refreshed after running git for side-effects, in addition to the +current Magit buffer, which is always refreshed automatically. + +Only set this to nil after exhausting all other options to +improve performance." + :package-version '(magit . "2.4.0") + :group 'magit-refresh + :group 'magit-status + :type 'boolean) + +(defcustom magit-refresh-verbose nil + "Whether to revert Magit buffers verbosely." + :package-version '(magit . "2.1.0") + :group 'magit-refresh + :type 'boolean) + +(defcustom magit-save-repository-buffers t + "Whether to save file-visiting buffers when appropriate. + +If non-nil, then all modified file-visiting buffers belonging +to the current repository may be saved before running Magit +commands and before creating or refreshing Magit buffers. +If `dontask', then this is done without user intervention, for +any other non-nil value the user has to confirm each save. + +The default is t to avoid surprises, but `dontask' is the +recommended value." + :group 'magit-essentials + :group 'magit-buffers + :type '(choice (const :tag "Never" nil) + (const :tag "Ask" t) + (const :tag "Save without asking" dontask))) + +;;; Key Bindings + +(defvar-keymap magit-mode-map + :doc "Parent keymap for all keymaps of modes derived from `magit-mode'." + :parent magit-section-mode-map + ;; Don't function-quote but make sure all commands are autoloaded. + "C-" 'magit-visit-thing + "RET" 'magit-visit-thing + "M-TAB" 'magit-dired-jump + "M-" 'magit-section-cycle-diffs + "SPC" 'magit-diff-show-or-scroll-up + "S-SPC" 'magit-diff-show-or-scroll-down + "DEL" 'magit-diff-show-or-scroll-down + "+" 'magit-diff-more-context + "-" 'magit-diff-less-context + "0" 'magit-diff-default-context + "a" 'magit-cherry-apply + "A" 'magit-cherry-pick + "b" 'magit-branch + "B" 'magit-bisect + "c" 'magit-commit + "C" 'magit-clone + "d" 'magit-diff + "D" 'magit-diff-refresh + "e" 'magit-ediff-dwim + "E" 'magit-ediff + "f" 'magit-fetch + "F" 'magit-pull + "g" 'magit-refresh + "G" 'magit-refresh-all + "h" 'magit-dispatch + "?" 'magit-dispatch + "H" 'magit-describe-section + "i" 'magit-gitignore + "I" 'magit-init + "j" 'magit-status-quick + "J" 'magit-display-repository-buffer + "k" 'magit-delete-thing + "K" 'magit-file-untrack + "l" 'magit-log + "L" 'magit-log-refresh + "m" 'magit-merge + "M" 'magit-remote + ;; "n" magit-section-forward in magit-section-mode-map + ;; "N" forge-dispatch, added by forge package + "o" 'magit-submodule + "O" 'magit-subtree + ;; "p" magit-section-backward in magit-section-mode-map + "P" 'magit-push + "q" 'magit-mode-bury-buffer + "Q" 'magit-git-command + ":" 'magit-git-command + "r" 'magit-rebase + "R" 'magit-file-rename + "s" 'magit-stage-files + "S" 'magit-stage-modified + "t" 'magit-tag + "T" 'magit-notes + "u" 'magit-unstage-files + "U" 'magit-unstage-all + "v" 'magit-revert-no-commit + "V" 'magit-revert + "w" 'magit-am + "W" 'magit-patch + "x" 'magit-reset-quickly + "X" 'magit-reset + "y" 'magit-show-refs + "Y" 'magit-cherry + "z" 'magit-stash + "Z" 'magit-worktree + "%" 'magit-worktree + "$" 'magit-process-buffer + "!" 'magit-run + ">" 'magit-sparse-checkout + "C-c C-c" 'magit-dispatch + "C-c C-r" 'magit-next-reference + "C-c C-e" 'magit-edit-thing + "C-c C-o" 'magit-browse-thing + "C-c C-w" 'magit-copy-thing + "C-w" 'magit-copy-section-value + "M-w" 'magit-copy-buffer-revision + " " 'magit-back-to-indentation + " " 'magit-previous-line + " " 'magit-next-line + " " 'evil-previous-visual-line + " " 'evil-next-visual-line) + +(defun magit-delete-thing () + "This is a placeholder command, which signals an error if called. +Where applicable, other keymaps remap this command to another, +which actually deletes the thing at point." + (interactive) + (user-error "There is no thing at point that could be deleted")) +;; Starting with Emacs 28.1 we could use (declare (completion ignore)). +(put 'magit-delete-thing 'completion-predicate #'ignore) + +(defun magit-visit-thing () + "This is a placeholder command, which may signal an error if called. +Where applicable, other keymaps remap this command to another, +which actually visits the thing at point." + (interactive) + (if (eq transient-current-command 'magit-dispatch) + (call-interactively (key-binding (this-command-keys))) + (if-let ((url (thing-at-point 'url t))) + (browse-url url) + (user-error "There is no thing at point that could be visited")))) +(put 'magit-visit-thing 'completion-predicate #'ignore) + +(defun magit-edit-thing () + "This is a placeholder command, which may signal an error if called. +Where applicable, other keymaps remap this command to another, +which actually lets you edit the thing at point, likely in another +buffer." + (interactive) + (if (eq transient-current-command 'magit-dispatch) + (call-interactively (key-binding (this-command-keys))) + (user-error "There is no thing at point that could be edited"))) +(put 'magit-edit-thing 'completion-predicate #'ignore) + +(defun magit-browse-thing () + "This is a placeholder command, which may signal an error if called. +Where applicable, other keymaps remap this command to another, +which actually visits thing at point using `browse-url'." + (interactive) + (if-let ((url (thing-at-point 'url t))) + (browse-url url) + (user-error "There is no thing at point that could be browsed"))) +(put 'magit-browse-thing 'completion-predicate #'ignore) + +(defun magit-copy-thing () + "This is a placeholder command, which signals an error if called. +Where applicable, other keymaps remap this command to another, +which actually copies some representation of the thing at point +to the kill ring." + (interactive) + (user-error "There is no thing at point that we know how to copy")) +(put 'magit-copy-thing 'completion-predicate #'ignore) + +;;;###autoload +(defun magit-info () + "Visit the Magit manual." + (interactive) + (info "magit")) + +(defvar bug-reference-map) +(with-eval-after-load 'bug-reference + (keymap-set bug-reference-map " " + 'bug-reference-push-button)) + +(easy-menu-define magit-mode-menu magit-mode-map + "Magit menu." + ;; Similar to `magit-dispatch' but exclude: + ;; - commands that are available from context menus: + ;; apply, reverse, discard, stage, unstage, + ;; cherry-pick, revert, reset, + ;; describe-section + ;; - commands that are available from submenus: + ;; git-command, ediff-dwim + ;; - and: refresh-all, status-jump, status-quick. + '("Magit" + "---" "Inspect" + [" Bisect..." magit-bisect t] + [" Cherries..." magit-cherry t] + [" Diff..." magit-diff t] + [" Ediff..." magit-ediff t] + [" Log..." magit-log t] + [" References..." magit-show-refs t] + "---" "Manipulate" + [" Commit..." magit-commit t] + [" Stash..." magit-stash t] + [" Tag..." magit-tag t] + "---" + [" Branch..." magit-branch t] + [" Remote..." magit-remote t] + "---" + [" Merge..." magit-merge t] + [" Rebase..." magit-rebase t] + "---" "Transfer" + [" Fetch..." magit-fetch t] + [" Pull..." magit-pull t] + [" Push..." magit-push t] + "---" "Setup" + [" Clone..." magit-clone t] + [" Ignore..." magit-gitignore t] + [" Init..." magit-init t] + "---" + ("Advanced" + ["Run..." magit-run t] + "---" + ["Apply patches..." magit-am t] + ["Format patches..." magit-patch t] + "---" + ["Note..." magit-notes t] + "---" + ["Submodule..." magit-submodule t] + ["Subtree..." magit-subtree t] + ["Worktree..." magit-worktree t]) + "---" + ["Show command dispatcher..." magit-dispatch t] + ["Show manual" magit-info t] + ["Show another buffer" magit-display-repository-buffer t] + "---" + ("Change buffer arguments" + ["Diff arguments" magit-diff-refresh t] + ["Log arguments" magit-log-refresh t]) + ["Refresh buffer" magit-refresh t] + ["Bury buffer" magit-mode-bury-buffer t])) + +;;; Mode + +(defun magit-load-config-extensions () + "Load Magit extensions that are defined at the Git config layer." + (dolist (ext (magit-get-all "magit.extension")) + (let ((sym (intern (format "magit-%s-mode" ext)))) + (when (fboundp sym) + (funcall sym 1))))) + +(define-derived-mode magit-mode magit-section-mode "Magit" + "Parent major mode from which Magit major modes inherit. + +Magit is documented in info node `(magit)'." + :interactive nil + :group 'magit + (magit-hack-dir-local-variables) + (face-remap-add-relative 'header-line 'magit-header-line) + (setq mode-line-process (magit-repository-local-get 'mode-line-process)) + (setq-local revert-buffer-function #'magit-revert-buffer) + (setq-local bookmark-make-record-function #'magit--make-bookmark) + (setq-local imenu-create-index-function #'magit--imenu-create-index) + (setq-local imenu-default-goto-function #'magit--imenu-goto-function) + (setq-local isearch-filter-predicate #'magit-section--open-temporarily)) + +(defun magit-hack-dir-local-variables () + "Like `hack-dir-local-variables-non-file-buffer' but ignore some variables." + (let ((ignored-local-variables + `(show-trailing-whitespace + ,@ignored-local-variables))) + (hack-dir-local-variables-non-file-buffer))) + +;;; Local Variables + +(defvar-local magit-buffer-arguments nil) +(defvar-local magit-buffer-diff-type nil) +(defvar-local magit-buffer-diff-args nil) +(defvar-local magit-buffer-diff-files nil) +(defvar-local magit-buffer-diff-files-suspended nil) +(defvar-local magit-buffer-file-name nil) +(defvar-local magit-buffer-files nil) +(defvar-local magit-buffer-log-args nil) +(defvar-local magit-buffer-log-files nil) +(defvar-local magit-buffer-range nil) +(defvar-local magit-buffer-range-hashed nil) +(defvar-local magit-buffer-refname nil) +(defvar-local magit-buffer-revision nil) +(defvar-local magit-buffer-revision-hash nil) +(defvar-local magit-buffer-revisions nil) +(defvar-local magit-buffer-typearg nil) +(defvar-local magit-buffer-upstream nil) + +;; These variables are also used in file-visiting buffers. +;; Because the user may change the major-mode, they have +;; to be permanent buffer-local. +(put 'magit-buffer-file-name 'permanent-local t) +(put 'magit-buffer-refname 'permanent-local t) +(put 'magit-buffer-revision 'permanent-local t) +(put 'magit-buffer-revision-hash 'permanent-local t) + +;; `magit-status' re-enables mode function but its refresher +;; function does not reinstate this. +(put 'magit-buffer-diff-files-suspended 'permanent-local t) + +(cl-defgeneric magit-buffer-value () + "Return the value of the current buffer. +The \"value\" identifies what is being displayed in the buffer. +The buffer's major-mode should derive from `magit-section-mode'." + nil) + +(defvar-local magit-previous-section nil) +(put 'magit-previous-section 'permanent-local t) + +;;; Setup Buffer + +(defmacro magit-setup-buffer (mode &optional locked &rest bindings) + (declare (indent 2)) + `(magit-setup-buffer-internal + ,mode ,locked + ,(cons 'list (mapcar (pcase-lambda (`(,var ,form)) + `(list ',var ,form)) + bindings)))) + +(defun magit-setup-buffer-internal ( mode locked bindings + &optional buffer-or-name directory) + (let* ((value (and locked + (with-temp-buffer + (pcase-dolist (`(,var ,val) bindings) + (set (make-local-variable var) val)) + (let ((major-mode mode)) + (magit-buffer-value))))) + (buffer (if buffer-or-name + (get-buffer-create buffer-or-name) + (magit-get-mode-buffer mode value))) + (section (and buffer (magit-current-section))) + (created (not buffer))) + (unless buffer + (setq buffer (magit-generate-new-buffer mode value))) + (with-current-buffer buffer + (setq magit-previous-section section) + (when directory + (setq default-directory directory)) + (funcall mode) + (magit-xref-setup #'magit-setup-buffer-internal bindings) + (pcase-dolist (`(,var ,val) bindings) + (set (make-local-variable var) val)) + (when created + (run-hooks 'magit-create-buffer-hook))) + (magit-display-buffer buffer) + (with-current-buffer buffer + (run-hooks 'magit-setup-buffer-hook) + (magit-refresh-buffer created) + (when created + (run-hooks 'magit-post-create-buffer-hook))) + buffer)) + +;;; Display Buffer + +(defvar magit-display-buffer-noselect nil + "If non-nil, then `magit-display-buffer' doesn't call `select-window'.") + +(defun magit-display-buffer (buffer &optional display-function) + "Display BUFFER in some window and maybe select it. + +If optional DISPLAY-FUNCTION is non-nil, then use that to display +the buffer. Otherwise use `magit-display-buffer-function', which +is the normal case. + +Then, unless `magit-display-buffer-noselect' is non-nil, select +the window which was used to display the buffer. + +Also run the hooks `magit-pre-display-buffer-hook' +and `magit-post-display-buffer-hook'." + (with-current-buffer buffer + (run-hooks 'magit-pre-display-buffer-hook)) + (let ((window (funcall (or display-function magit-display-buffer-function) + buffer))) + (unless magit-display-buffer-noselect + (let* ((old-frame (selected-frame)) + (new-frame (window-frame window))) + (select-window window) + (unless (eq old-frame new-frame) + (select-frame-set-input-focus new-frame))))) + (with-current-buffer buffer + (run-hooks 'magit-post-display-buffer-hook))) + +(defun magit-display-buffer-traditional (buffer) + "Display BUFFER the way this has traditionally been done." + (display-buffer + buffer (if (and (derived-mode-p 'magit-mode) + (not (memq (with-current-buffer buffer major-mode) + '(magit-process-mode + magit-revision-mode + magit-diff-mode + magit-stash-mode + magit-status-mode)))) + '(display-buffer-same-window) + nil))) ; display in another window + +(defun magit-display-buffer-same-window-except-diff-v1 (buffer) + "Display BUFFER in the selected window except for some modes. +If a buffer's `major-mode' derives from `magit-diff-mode' or +`magit-process-mode', display it in another window. Display all +other buffers in the selected window." + (display-buffer + buffer (if (with-current-buffer buffer + (derived-mode-p 'magit-diff-mode 'magit-process-mode)) + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window)))) + +(defun magit--display-buffer-fullframe (buffer alist) + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) + (delete-other-windows window) + window)) + +(defun magit-display-buffer-fullframe-status-v1 (buffer) + "Display BUFFER, filling entire frame if BUFFER is a status buffer. +Otherwise, behave like `magit-display-buffer-traditional'." + (if (eq (with-current-buffer buffer major-mode) + 'magit-status-mode) + (display-buffer buffer '(magit--display-buffer-fullframe)) + (magit-display-buffer-traditional buffer))) + +(defun magit--display-buffer-topleft (buffer alist) + (or (display-buffer-reuse-window buffer alist) + (when-let ((window2 (display-buffer-pop-up-window buffer alist))) + (let ((window1 (get-buffer-window)) + (buffer1 (current-buffer)) + (buffer2 (window-buffer window2)) + (w2-quit-restore (window-parameter window2 'quit-restore))) + (set-window-buffer window1 buffer2) + (set-window-buffer window2 buffer1) + (select-window window2) + ;; Swap some window state that `magit-mode-quit-window' and + ;; `quit-restore-window' inspect. + (set-window-prev-buffers window2 (cdr (window-prev-buffers window1))) + (set-window-prev-buffers window1 nil) + (set-window-parameter window2 'magit-dedicated + (window-parameter window1 'magit-dedicated)) + (set-window-parameter window1 'magit-dedicated t) + (set-window-parameter window1 'quit-restore + (list 'window 'window + (nth 2 w2-quit-restore) + (nth 3 w2-quit-restore))) + (set-window-parameter window2 'quit-restore nil) + window1)))) + +(defun magit-display-buffer-fullframe-status-topleft-v1 (buffer) + "Display BUFFER, filling entire frame if BUFFER is a status buffer. +When BUFFER derives from `magit-diff-mode' or +`magit-process-mode', try to display BUFFER to the top or left of +the current buffer rather than to the bottom or right, as +`magit-display-buffer-fullframe-status-v1' would. Whether the +split is made vertically or horizontally is determined by +`split-window-preferred-function'." + (display-buffer + buffer + (cond ((eq (with-current-buffer buffer major-mode) + 'magit-status-mode) + '(magit--display-buffer-fullframe)) + ((with-current-buffer buffer + (derived-mode-p 'magit-diff-mode 'magit-process-mode)) + '(magit--display-buffer-topleft)) + (t + '(display-buffer-same-window))))) + +(defun magit--display-buffer-fullcolumn (buffer alist) + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-below-selected buffer alist)))) + (delete-other-windows-vertically window) + window)) + +(defun magit-display-buffer-fullcolumn-most-v1 (buffer) + "Display BUFFER using the full column except in some cases. +For most cases where BUFFER's `major-mode' derives from +`magit-mode', display it in the selected window and grow that +window to the full height of the frame, deleting other windows in +that column as necessary. However, display BUFFER in another +window if 1) BUFFER's mode derives from `magit-process-mode', or +2) BUFFER's mode derives from `magit-diff-mode', provided that +the mode of the current buffer derives from `magit-log-mode' or +`magit-cherry-mode'." + (display-buffer + buffer + (cond ((and (or (bound-and-true-p git-commit-mode) + (derived-mode-p 'magit-log-mode + 'magit-cherry-mode + 'magit-reflog-mode)) + (with-current-buffer buffer + (derived-mode-p 'magit-diff-mode))) + nil) + ((with-current-buffer buffer + (derived-mode-p 'magit-process-mode)) + nil) + (t + '(magit--display-buffer-fullcolumn))))) + +(defun magit-maybe-set-dedicated () + "Mark the selected window as dedicated if appropriate. + +If a new window was created to display the buffer, then remember +that fact. That information is used by `magit-mode-quit-window', +to determine whether the window should be deleted when its last +Magit buffer is buried." + (let ((window (get-buffer-window (current-buffer)))) + (when (and (window-live-p window) + (not (window-prev-buffers window))) + (set-window-parameter window 'magit-dedicated t)))) + +;;; Get Buffer + +(defvar-local magit--default-directory nil + "Value of `default-directory' when buffer is generated. +This exists to prevent a let-bound `default-directory' from +tricking `magit-get-mode-buffer' or `magit-mode-get-buffers' +into thinking a buffer belongs to a repo that it doesn't.") +(put 'magit--default-directory 'permanent-local t) + +(defun magit-mode-get-buffers () + (let ((topdir (magit-toplevel))) + (seq-filter (##with-current-buffer % + (and (derived-mode-p 'magit-mode) + (equal magit--default-directory topdir))) + (buffer-list)))) + +(defvar-local magit-buffer-locked-p nil) +(put 'magit-buffer-locked-p 'permanent-local t) + +(defun magit-get-mode-buffer (mode &optional value frame) + "Return buffer belonging to the current repository whose major-mode is MODE. + +If no such buffer exists then return nil. Multiple buffers with +the same major-mode may exist for a repository but only one can +exist that hasn't been locked to its value. Return that buffer +\(or nil if there is no such buffer) unless VALUE is non-nil, in +which case return the buffer that has been locked to that value. + +If FRAME is nil or omitted, then consider all buffers. Otherwise + only consider buffers that are displayed in some live window + on some frame. +If `all', then consider all buffers on all frames. +If `visible', then only consider buffers on all visible frames. +If `selected' or t, then only consider buffers on the selected + frame. +If a frame, then only consider buffers on that frame." + (let ((topdir (magit--toplevel-safe))) + (cl-flet* ((b (buffer) + (with-current-buffer buffer + (and (eq major-mode mode) + (equal magit--default-directory topdir) + (if value + (and magit-buffer-locked-p + (equal (magit-buffer-value) value)) + (not magit-buffer-locked-p)) + buffer))) + (w (window) + (b (window-buffer window))) + (f (frame) + (seq-some #'w (window-list frame 'no-minibuf)))) + (pcase-exhaustive frame + ('nil (seq-some #'b (buffer-list))) + ('all (seq-some #'f (frame-list))) + ('visible (seq-some #'f (visible-frame-list))) + ((or 'selected 't) (seq-some #'w (window-list (selected-frame)))) + ((guard (framep frame)) (seq-some #'w (window-list frame))))))) + +(defun magit-generate-new-buffer (mode &optional value directory) + (let* ((default-directory (or directory (magit--toplevel-safe))) + (name (funcall magit-generate-buffer-name-function mode value)) + (buffer (generate-new-buffer name))) + (with-current-buffer buffer + (setq magit--default-directory default-directory) + (setq magit-buffer-locked-p (and value t)) + (magit-restore-section-visibility-cache mode)) + (magit--maybe-uniquify-buffer-names buffer name mode) + buffer)) + +(defun magit-generate-buffer-name-default-function (mode &optional value) + "Generate buffer name for a MODE buffer in the current repository. +The returned name is based on `magit-buffer-name-format' and +takes `magit-uniquify-buffer-names' and VALUE, if non-nil, into +account." + (let ((m (substring (symbol-name mode) 0 -5)) + (v (and value (format "%s" (ensure-list value)))) + (n (if magit-uniquify-buffer-names + (file-name-nondirectory + (directory-file-name default-directory)) + (abbreviate-file-name default-directory)))) + (format-spec + magit-buffer-name-format + `((?m . ,m) + (?M . ,(if (eq mode 'magit-status-mode) "magit" m)) + (?v . ,(or v "")) + (?V . ,(if v (concat " " v) "")) + (?t . ,n) + (?x . ,(if magit-uniquify-buffer-names "" "*")))))) + +(defun magit--maybe-uniquify-buffer-names (buffer name mode) + (when magit-uniquify-buffer-names + (cl-pushnew mode uniquify-list-buffers-directory-modes) + (with-current-buffer buffer + (setq list-buffers-directory (abbreviate-file-name default-directory))) + (let ((uniquify-buffer-name-style + (if (memq uniquify-buffer-name-style '(nil forward)) + 'post-forward-angle-brackets + uniquify-buffer-name-style))) + (uniquify-rationalize-file-buffer-names + name (file-name-directory (directory-file-name default-directory)) + buffer)))) + +;;; Buffer Lock + +(defun magit-toggle-buffer-lock () + "Lock the current buffer to its value or unlock it. + +Locking a buffer to its value prevents it from being reused to +display another value. The name of a locked buffer contains its +value, which allows telling it apart from other locked buffers +and the unlocked buffer. + +Not all Magit buffers can be locked to their values, for example +it wouldn't make sense to lock a status buffer. + +There can only be a single unlocked buffer using a certain +major-mode per repository. So when a buffer is being unlocked +and another unlocked buffer already exists for that mode and +repository, then the former buffer is instead deleted and the +latter is displayed in its place." + (interactive) + (if magit-buffer-locked-p + (if-let ((unlocked (magit-get-mode-buffer major-mode))) + (let ((locked (current-buffer))) + (switch-to-buffer unlocked nil t) + (kill-buffer locked)) + (setq magit-buffer-locked-p nil) + (let ((name (funcall magit-generate-buffer-name-function major-mode)) + (buffer (current-buffer)) + (mode major-mode)) + (rename-buffer (generate-new-buffer-name name)) + (with-temp-buffer + (magit--maybe-uniquify-buffer-names buffer name mode)))) + (if-let ((value (magit-buffer-value))) + (if-let ((locked (magit-get-mode-buffer major-mode value))) + (let ((unlocked (current-buffer))) + (switch-to-buffer locked nil t) + (kill-buffer unlocked)) + (setq magit-buffer-locked-p t) + (let ((name (funcall magit-generate-buffer-name-function + major-mode value)) + (buffer (current-buffer)) + (mode major-mode)) + (rename-buffer (generate-new-buffer-name name)) + (with-temp-buffer + (magit--maybe-uniquify-buffer-names buffer name mode)))) + (user-error "Buffer has no value it could be locked to")))) + +;;; Bury Buffer + +(defun magit-mode-bury-buffer (&optional kill-buffer) + "Bury or kill the current buffer. + +Use `magit-bury-buffer-function' to bury the buffer when called +without a prefix argument or to kill it when called with a single +prefix argument. + +With two prefix arguments, always kill the current and all other +Magit buffers, associated with this repository." + (interactive "P") + (if (>= (prefix-numeric-value kill-buffer) 16) + (mapc #'kill-buffer (magit-mode-get-buffers)) + (funcall magit-bury-buffer-function kill-buffer))) + +(defun magit-mode-quit-window (kill-buffer) + "Quit the selected window and bury its buffer. + +This behaves similar to `quit-window', but when the window +was originally created to display a Magit buffer and the +current buffer is the last remaining Magit buffer that was +ever displayed in the selected window, then delete that +window." + (if (or (one-window-p) + (seq-find (pcase-lambda (`(,buffer)) + (and (not (eq buffer (current-buffer))) + (buffer-live-p buffer) + (or (not (window-parameter nil 'magit-dedicated)) + (with-current-buffer buffer + (derived-mode-p 'magit-mode + 'magit-process-mode))))) + (window-prev-buffers))) + (quit-window kill-buffer) + (let ((window (selected-window))) + (quit-window kill-buffer) + (when (window-live-p window) + (delete-window window))))) + +;;; Refresh Buffers + +(defvar magit-inhibit-refresh nil) + +(defun magit-refresh () + "Refresh some buffers belonging to the current repository. + +Refresh the current buffer if its major mode derives from +`magit-mode', and refresh the corresponding status buffer. + +Run hooks `magit-pre-refresh-hook', `magit-post-refresh-hook' +and `magit-unwind-refresh-hook'." + (interactive) + (unless magit-inhibit-refresh + (unwind-protect + (let ((start (current-time)) + (magit--refresh-cache (or magit--refresh-cache + (list (cons 0 0))))) + (when magit-refresh-verbose + (message "Refreshing magit...")) + (magit-run-hook-with-benchmark 'magit-pre-refresh-hook) + (cond ((derived-mode-p 'magit-mode) + (magit-refresh-buffer)) + ((derived-mode-p 'tabulated-list-mode) + (revert-buffer))) + (when-let ((buffer (and magit-refresh-status-buffer + (not (derived-mode-p 'magit-status-mode)) + (magit-get-mode-buffer 'magit-status-mode)))) + (with-current-buffer buffer + (magit-refresh-buffer))) + (magit-run-hook-with-benchmark 'magit-post-refresh-hook) + (when magit-refresh-verbose + (let* ((c (caar magit--refresh-cache)) + (a (+ c (cdar magit--refresh-cache)))) + (message "Refreshing magit...done (%.3fs, cached %s/%s (%.0f%%))" + (float-time (time-since start)) + c a (* (/ c (* a 1.0)) 100))))) + (run-hooks 'magit-unwind-refresh-hook)))) + +(defun magit-refresh-all () + "Refresh all buffers belonging to the current repository. + +Refresh all Magit buffers belonging to the current repository, +and revert buffers that visit files located inside the current +repository. + +Run hooks `magit-pre-refresh-hook' and `magit-post-refresh-hook'." + (interactive) + (magit-run-hook-with-benchmark 'magit-pre-refresh-hook) + (dolist (buffer (magit-mode-get-buffers)) + (with-current-buffer buffer (magit-refresh-buffer))) + (magit-run-hook-with-benchmark 'magit-post-refresh-hook)) + +(defvar-local magit--refresh-start-time nil) + +(defvar magit--initial-section-hook nil) + +(defun magit-refresh-buffer (&optional created) + "Refresh the current Magit buffer." + (interactive) + (when-let ((refresh (magit--refresh-buffer-function))) + (let ((magit--refreshing-buffer-p t) + (magit--refresh-start-time (current-time)) + (magit--refresh-cache (or magit--refresh-cache (list (cons 0 0)))) + (action (if created "Creating" "Refreshing"))) + (when magit-refresh-verbose + (message "%s buffer `%s'..." action (buffer-name))) + (cond + (created + (funcall refresh) + (run-hooks 'magit--initial-section-hook) + (setq-local magit--initial-section-hook nil)) + (t + (deactivate-mark) + (setq magit-section-pre-command-section nil) + (setq magit-section-highlight-overlays nil) + (setq magit-section-selection-overlays nil) + (setq magit-section-highlighted-sections nil) + (setq magit-section-focused-sections nil) + (let ((positions (magit--refresh-buffer-get-positions))) + (funcall refresh) + (magit--refresh-buffer-set-positions positions)))) + (let ((magit-section-cache-visibility nil)) + (magit-section-show magit-root-section)) + (run-hooks 'magit-refresh-buffer-hook) + (magit-section-update-highlight) + (set-buffer-modified-p nil) + (push (current-buffer) magit-section--refreshed-buffers) + (when magit-refresh-verbose + (message "%s buffer `%s'...done (%.3fs)" action (buffer-name) + (float-time (time-since magit--refresh-start-time))))))) + +(defun magit--refresh-buffer-function () + (let ((fn (intern (format "%s-refresh-buffer" + (substring (symbol-name major-mode) 0 -5))))) + (and (functionp fn) + (lambda () + (let ((inhibit-read-only t)) + (erase-buffer) + (save-excursion (funcall fn))))))) + +(defun magit--refresh-buffer-get-positions () + (or (let ((buffer (current-buffer))) + (mapcan + (lambda (window) + (with-selected-window window + (with-current-buffer buffer + (and-let* ((section (magit-section-at))) + `((,window + ,section + ,@(magit-section-get-relative-position section) + ,@(and-let* ((ws (magit-section-at (window-start)))) + (list ws + (car (magit-section-get-relative-position ws)) + (window-start))))))))) + (get-buffer-window-list buffer nil t))) + (and-let* ((section (magit-section-at))) + `((nil ,section ,@(magit-section-get-relative-position section)))))) + +(defun magit--refresh-buffer-set-positions (positions) + (pcase-dolist + (`(,window ,section ,line ,char ,ws-section ,ws-line ,window-start) + positions) + (if window + (with-selected-window window + (magit-section-goto-successor section line char) + (cond + ((or (not window-start) + (> window-start (point)))) + ((magit-section-equal ws-section (magit-section-at window-start)) + (set-window-start window window-start t)) + ((not (derived-mode-p 'magit-log-mode)) + (when-let ((pos (save-excursion + (and (magit-section-goto-successor--same + ws-section ws-line 0) + (point))))) + (set-window-start window pos t))))) + (magit-section-goto-successor section line char)))) + +(defun magit-revert-buffer (_ignore-auto _noconfirm) + "Wrapper around `magit-refresh-buffer' suitable as `revert-buffer-function'." + (magit-refresh-buffer)) + +(defun magit-profile-refresh-buffer () + "Profile refreshing the current Magit buffer." + (interactive) + (require (quote elp)) + (elp-reset-all) + (message "Profiling Magit and Forge...") + (elp-instrument-package "magit-") + (elp-instrument-package "forge-") + (magit-refresh-buffer) + (message "Profiling Magit and Forge...done") + (elp-results) + (elp-reset-all)) + +(defun magit-toggle-profiling () + "Start profiling Magit, or if in progress, stop and display the results." + (interactive) + (require (quote elp)) + (cond ((catch 'in-progress + (mapatoms (##and (get % elp-timer-info-property) + (throw 'in-progress t)))) + (message "Stop profiling and display results...") + (elp-results) + (elp-restore-all)) + (t + (message "Start profiling Magit and Forge...") + (elp-reset-all) + (elp-instrument-package "magit-") + (elp-instrument-package "forge-")))) + +;;; Save File-Visiting Buffers + +(defvar magit--disable-save-buffers nil) + +(defun magit-pre-command-hook () + (setq magit--disable-save-buffers nil)) +(add-hook 'pre-command-hook #'magit-pre-command-hook) + +(defvar magit-after-save-refresh-buffers nil) + +(defun magit-after-save-refresh-buffers () + (unless magit-inhibit-refresh + (dolist (buffer magit-after-save-refresh-buffers) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (magit-refresh-buffer)))) + (setq magit-after-save-refresh-buffers nil) + (remove-hook 'post-command-hook #'magit-after-save-refresh-buffers))) + +(defun magit-after-save-refresh-status () + "Refresh the status buffer of the current repository. + +This function is intended to be added to `after-save-hook'. + +If the status buffer does not exist or the file being visited in +the current buffer isn't inside the working tree of a repository, +then do nothing. + +Note that refreshing a Magit buffer is done by re-creating its +contents from scratch, which can be slow in large repositories. +If you are not satisfied with Magit's performance, then you +should obviously not add this function to that hook." + (when-let (((and (not magit-inhibit-refresh) + (magit-inside-worktree-p t))) + (buf (ignore-errors (magit-get-mode-buffer 'magit-status-mode)))) + (cl-pushnew buf magit-after-save-refresh-buffers) + (add-hook 'post-command-hook #'magit-after-save-refresh-buffers))) + +(defun magit-maybe-save-repository-buffers () + "Maybe save file-visiting buffers belonging to the current repository. +Do so if `magit-save-repository-buffers' is non-nil. You should +not remove this from any hooks, instead set that variable to nil +if you so desire." + (when (and magit-save-repository-buffers + (not magit--disable-save-buffers)) + (setq magit--disable-save-buffers t) + (let ((msg (current-message))) + (magit-save-repository-buffers + (eq magit-save-repository-buffers 'dontask)) + (when (and msg + (current-message) + (not (equal msg (current-message)))) + (message "%s" msg))))) + +(defvar-local magit-inhibit-refresh-save nil) + +(defun magit-save-repository-buffers (&optional arg) + "Save file-visiting buffers belonging to the current repository. +After any buffer where `buffer-save-without-query' is non-nil +is saved without asking, the user is asked about each modified +buffer which visits a file in the current repository. Optional +argument (the prefix) non-nil means save all with no questions." + (interactive "P") + (when-let ((topdir (magit-rev-parse-safe "--show-toplevel"))) + (let ((remote (file-remote-p default-directory)) + (save-some-buffers-action-alist + `((?Y ,(##with-current-buffer % + (setq buffer-save-without-query t) + (save-buffer)) + "to save the current buffer and remember choice") + (?N ,(##with-current-buffer % + (setq magit-inhibit-refresh-save t)) + "to skip the current buffer and remember choice") + ,@save-some-buffers-action-alist)) + (topdirs nil) + (unwiped nil) + (magit--wip-inhibit-autosave t)) + (unwind-protect + (save-some-buffers + arg + (lambda () + ;; If the current file is modified and resides inside + ;; a repository, and a let-binding is in effect, which + ;; places us in another repository, then this binding + ;; is needed to prevent that file from being saved. + (and-let* ((default-directory + (and buffer-file-name + (file-name-directory buffer-file-name)))) + (and + ;; Check whether the repository still exists. + (file-exists-p default-directory) + ;; Check whether refreshing is disabled. + (not magit-inhibit-refresh-save) + ;; Check whether the visited file is either on the + ;; same remote as the repository, or both are on + ;; the local system. + (equal (file-remote-p buffer-file-name) remote) + ;; Delayed checks that are more expensive for remote + ;; repositories, due to the required network access. + ;; + ;; Check whether the file is inside the repository. + (equal (or (cdr (assoc default-directory topdirs)) + (let ((top (magit-rev-parse-safe "--show-toplevel"))) + (push (cons default-directory top) topdirs) + top)) + topdir) + ;; Check whether the file is actually writable. + (file-writable-p buffer-file-name) + (prog1 t + ;; Schedule for wip commit, if appropriate. + (when magit-wip-after-save-local-mode + (push (expand-file-name buffer-file-name) unwiped))))))) + (when unwiped + (let ((default-directory topdir)) + (magit-wip-commit-worktree + (magit-wip-get-ref) + unwiped + (if (cdr unwiped) + (format "autosave %s files after save" (length unwiped)) + (format "autosave %s after save" + (file-relative-name (car unwiped))))))))))) + +;;; Restore Window Configuration + +(defvar magit-inhibit-save-previous-winconf nil) + +(defvar-local magit-previous-window-configuration nil) +(put 'magit-previous-window-configuration 'permanent-local t) + +(defun magit-save-window-configuration () + "Save the current window configuration. + +Later, when the buffer is buried, it may be restored by +`magit-restore-window-configuration'." + (if magit-inhibit-save-previous-winconf + (when (eq magit-inhibit-save-previous-winconf 'unset) + (setq magit-previous-window-configuration nil)) + (unless (get-buffer-window (current-buffer) (selected-frame)) + (setq magit-previous-window-configuration + (current-window-configuration))))) + +(defun magit-restore-window-configuration (&optional kill-buffer) + "Bury or kill the current buffer and restore previous window configuration." + (let ((winconf magit-previous-window-configuration) + (buffer (current-buffer)) + (frame (selected-frame))) + (quit-window kill-buffer (selected-window)) + (when (and winconf (equal frame (window-configuration-frame winconf))) + (set-window-configuration winconf) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq magit-previous-window-configuration nil))) + (set-buffer (with-selected-window (selected-window) + (current-buffer)))))) + +;;; Buffer History + +(defun magit-go-backward () + "Move backward in current buffer's history." + (interactive) + (if help-xref-stack + (help-xref-go-back (current-buffer)) + (user-error "No previous entry in buffer's history"))) + +(defun magit-go-forward () + "Move forward in current buffer's history." + (interactive) + (if help-xref-forward-stack + (help-xref-go-forward (current-buffer)) + (user-error "No next entry in buffer's history"))) + +(defun magit-insert-xref-buttons () + "Insert xref buttons." + (when (and (not magit-buffer-locked-p) + (or help-xref-stack help-xref-forward-stack)) + (when help-xref-stack + (magit-xref-insert-button help-back-label 'magit-xref-backward)) + (when help-xref-forward-stack + (when help-xref-stack + (insert " ")) + (magit-xref-insert-button help-forward-label 'magit-xref-forward)))) + +(defun magit-xref-insert-button (label type) + (magit-insert-section (button label) + (insert-text-button label 'type type + 'help-args (list (current-buffer))))) + +(define-button-type 'magit-xref-backward + :supertype 'help-back + 'mouse-face 'magit-section-highlight + 'help-echo (purecopy "mouse-2, RET: go back to previous history entry")) + +(define-button-type 'magit-xref-forward + :supertype 'help-forward + 'mouse-face 'magit-section-highlight + 'help-echo (purecopy "mouse-2, RET: go back to next history entry")) + +(defvar magit-xref-modes + ;; Do not function-quote to avoid circular dependencies. + '(magit-log-mode + magit-reflog-mode + magit-diff-mode + magit-revision-mode) + "List of modes for which to insert navigation buttons.") + +(defun magit-xref-setup (fn args) + (when (memq major-mode magit-xref-modes) + (when help-xref-stack-item + (push (cons (point) help-xref-stack-item) help-xref-stack) + (setq help-xref-forward-stack nil)) + (when-let ((tail (nthcdr 30 help-xref-stack))) + (setcdr tail nil)) + (setq help-xref-stack-item + (list 'magit-xref-restore fn default-directory args)))) + +(defun magit-xref-restore (fn dir args) + (setq default-directory dir) + (funcall fn major-mode nil args) + (magit-refresh-buffer)) + +;;; Repository-Local Cache + +(defvar magit-repository-local-cache nil + "Alist mapping `magit-toplevel' paths to alists of key/value pairs.") + +(defun magit-repository-local-repository () + "Return the key for the current repository." + (or (bound-and-true-p magit--default-directory) + (magit-toplevel))) + +(defun magit-repository-local-set (key value &optional repository) + "Set the repository-local VALUE for KEY. + +Unless specified, REPOSITORY is the current buffer's repository. + +If REPOSITORY is nil (meaning there is no current repository), +then the value is not cached, and we return nil." + (let* ((repokey (or repository (magit-repository-local-repository))) + (cache (assoc repokey magit-repository-local-cache))) + ;; Don't cache values for a nil REPOSITORY, as the 'set' and 'get' + ;; calls for some KEY may happen in unrelated contexts. + (when repokey + (if cache + (let ((keyvalue (assoc key (cdr cache)))) + (if keyvalue + ;; Update pre-existing value for key. + (setcdr keyvalue value) + ;; No such key in repository-local cache. + (push (cons key value) (cdr cache)))) + ;; No cache for this repository. + (push (cons repokey (list (cons key value))) + magit-repository-local-cache))))) + +(defun magit-repository-local-exists-p (key &optional repository) + "Non-nil when a repository-local value exists for KEY. + +Return a (KEY . VALUE) cons cell. + +The KEY is matched using `equal'. + +Unless specified, REPOSITORY is the current buffer's repository." + (and-let* ((cache (assoc (or repository + (magit-repository-local-repository)) + magit-repository-local-cache))) + (assoc key (cdr cache)))) + +(defun magit-repository-local-get (key &optional default repository) + "Return the repository-local value for KEY. + +Return DEFAULT if no value for KEY exists. + +The KEY is matched using `equal'. + +Unless specified, REPOSITORY is the current buffer's repository." + (if-let ((keyvalue (magit-repository-local-exists-p key repository))) + (cdr keyvalue) + default)) + +(defun magit-repository-local-delete (key &optional repository) + "Delete the repository-local value for KEY. + +Unless specified, REPOSITORY is the current buffer's repository. +If REPOSITORY is `all', then delete the value for KEY for all +repositories." + (if (eq repository 'all) + (dolist (cache magit-repository-local-cache) + (setf cache (compat-call assoc-delete-all key cache))) + (when-let ((cache (assoc (or repository + (magit-repository-local-repository)) + magit-repository-local-cache))) + (setf cache (compat-call assoc-delete-all key cache))))) + +(defmacro magit--with-repository-local-cache (key &rest body) + (declare (indent 1) (debug (form body))) + (let ((k (gensym))) + `(let ((,k ,key)) + (if-let ((kv (magit-repository-local-exists-p ,k))) + (cdr kv) + (let ((v ,(macroexp-progn body))) + (magit-repository-local-set ,k v) + v))))) + +(defun magit-preserve-section-visibility-cache () + (when (derived-mode-p 'magit-status-mode 'magit-refs-mode) + (magit-repository-local-set + (cons major-mode 'magit-section-visibility-cache) + magit-section-visibility-cache))) + +(defun magit-restore-section-visibility-cache (mode) + (setq magit-section-visibility-cache + (magit-repository-local-get + (cons mode 'magit-section-visibility-cache)))) + +(defun magit-zap-caches (&optional all) + "Zap caches for the current repository. + +Remove the repository's entry from `magit-repository-local-cache', +remove the host's entry from `magit--host-git-version-cache', and +set `magit-section-visibility-cache' to nil for all Magit buffers +of the repository. + +With a prefix argument or if optional ALL is non-nil, discard the +mentioned caches completely." + (interactive) + (cond (all + (setq magit-repository-local-cache nil) + (setq magit--host-git-version-cache nil) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'magit-mode) + (setq magit-section-visibility-cache nil))))) + (t + (magit-with-toplevel + (setq magit-repository-local-cache + (cl-delete default-directory + magit-repository-local-cache + :key #'car :test #'equal)) + (setq magit--host-git-version-cache + (cl-delete (file-remote-p default-directory) + magit--host-git-version-cache + :key #'car :test #'equal))) + (dolist (buffer (magit-mode-get-buffers)) + (with-current-buffer buffer + (setq magit-section-visibility-cache nil)))))) + +;;; Utilities + +(defun magit-toggle-verbose-refresh () + "Toggle whether Magit refreshes buffers verbosely. +Enabling this helps figuring out which sections are bottlenecks. +The additional output can be found in the *Messages* buffer." + (interactive) + (setq magit-refresh-verbose (not magit-refresh-verbose)) + (message "%s verbose refreshing" + (if magit-refresh-verbose "Enabled" "Disabled"))) + +(defun magit-run-hook-with-benchmark (hook) + (cond + ((not hook)) + (magit-refresh-verbose + (message "Running %s..." hook) + (message "Running %s...done (%.3fs)" hook + (benchmark-elapse + (run-hook-wrapped + hook + (lambda (fn) + (message " %-50s %f" fn (benchmark-elapse (funcall fn)))))))) + ((run-hooks hook)))) + +(defun magit-file-region-line-numbers () + "Return the bounds of the region as line numbers. +The returned value has the form (BEGINNING-LINE END-LINE). If +the region end at the beginning of a line, do not include that +line. Avoid including the line after the end of the file." + (and (or magit-buffer-file-name buffer-file-name) + (region-active-p) + (not (= (region-beginning) (region-end) (1+ (buffer-size)))) + (let ((beg (region-beginning)) + (end (min (region-end) (buffer-size)))) + (list (line-number-at-pos beg t) + (line-number-at-pos (if (= (magit--bol-position end) end) + (max beg (1- end)) + end) + t))))) + +;;; _ +(provide 'magit-mode) +;;; magit-mode.el ends here blob - /dev/null blob + 0b262158e71a18ffba52d48b61c141cd925125d3 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-notes.el @@ -0,0 +1,201 @@ +;;; magit-notes.el --- Notes support -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for `git-notes'. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-notes "magit" nil t) +(transient-define-prefix magit-notes () + "Edit notes attached to commits." + :man-page "git-notes" + ["Configure local settings" + ("c" magit-core.notesRef) + ("d" magit-notes.displayRef)] + ["Configure global settings" + ("C" magit-global-core.notesRef) + ("D" magit-global-notes.displayRef)] + ["Arguments for prune" + :if-not magit-notes-merging-p + ("-n" "Dry run" ("-n" "--dry-run"))] + ["Arguments for edit and remove" + :if-not magit-notes-merging-p + (magit-notes:--ref)] + ["Arguments for merge" + :if-not magit-notes-merging-p + (magit-notes:--strategy)] + ["Actions" + :if-not magit-notes-merging-p + ("T" "Edit" magit-notes-edit) + ("r" "Remove" magit-notes-remove) + ("m" "Merge" magit-notes-merge) + ("p" "Prune" magit-notes-prune)] + ["Actions" + :if magit-notes-merging-p + ("c" "Commit merge" magit-notes-merge-commit) + ("a" "Abort merge" magit-notes-merge-abort)]) + +(defun magit-notes-merging-p () + (let ((dir (expand-file-name "NOTES_MERGE_WORKTREE" (magit-gitdir)))) + (and (file-directory-p dir) + (directory-files dir nil "\\`[^.]")))) + +(transient-define-infix magit-core.notesRef () + :class 'magit--git-variable + :variable "core.notesRef" + :reader #'magit-notes-read-ref + :prompt "Set local core.notesRef") + +(transient-define-infix magit-notes.displayRef () + :class 'magit--git-variable + :variable "notes.displayRef" + :multi-value t + :reader #'magit-notes-read-refs + :prompt "Set local notes.displayRef") + +(transient-define-infix magit-global-core.notesRef () + :class 'magit--git-variable + :variable "core.notesRef" + :global t + :reader #'magit-notes-read-ref + :prompt "Set global core.notesRef") + +(transient-define-infix magit-global-notes.displayRef () + :class 'magit--git-variable + :variable "notes.displayRef" + :global t + :multi-value t + :reader #'magit-notes-read-refs + :prompt "Set global notes.displayRef") + +(transient-define-argument magit-notes:--ref () + :description "Manipulate ref" + :class 'transient-option + :key "-r" + :argument "--ref=" + :reader #'magit-notes-read-ref) + +(transient-define-argument magit-notes:--strategy () + :description "Merge strategy" + :class 'transient-option + :shortarg "-s" + :argument "--strategy=" + :choices '("manual" "ours" "theirs" "union" "cat_sort_uniq")) + +(defun magit-notes-edit (commit &optional ref) + "Edit the note attached to COMMIT. +REF is the notes ref used to store the notes. + +Interactively or when optional REF is nil use the value of Git +variable `core.notesRef' or \"refs/notes/commits\" if that is +undefined." + (interactive (magit-notes-read-args "Edit notes")) + (magit-run-git-with-editor "notes" (and ref (concat "--ref=" ref)) + "edit" commit)) + +(defun magit-notes-remove (commit &optional ref) + "Remove the note attached to COMMIT. +REF is the notes ref from which the note is removed. + +Interactively or when optional REF is nil use the value of Git +variable `core.notesRef' or \"refs/notes/commits\" if that is +undefined." + (interactive (magit-notes-read-args "Remove notes")) + (magit-run-git-with-editor "notes" (and ref (concat "--ref=" ref)) + "remove" commit)) + +(defun magit-notes-merge (ref) + "Merge the notes ref REF into the current notes ref. + +The current notes ref is the value of Git variable +`core.notesRef' or \"refs/notes/commits\" if that is undefined. + +When there are conflicts, then they have to be resolved in the +temporary worktree \".git/NOTES_MERGE_WORKTREE\". When +done use `magit-notes-merge-commit' to finish. To abort +use `magit-notes-merge-abort'." + (interactive (list (magit-read-string-ns "Merge reference"))) + (magit-run-git-with-editor "notes" "merge" ref)) + +(defun magit-notes-merge-commit () + "Commit the current notes ref merge. +Also see `magit-notes-merge'." + (interactive) + (magit-run-git-with-editor "notes" "merge" "--commit")) + +(defun magit-notes-merge-abort () + "Abort the current notes ref merge. +Also see `magit-notes-merge'." + (interactive) + (magit-run-git-with-editor "notes" "merge" "--abort")) + +(defun magit-notes-prune (&optional dry-run) + "Remove notes about unreachable commits." + (interactive (list (and (member "--dry-run" (transient-args 'magit-notes)) t))) + (when dry-run + (magit-process-buffer)) + (magit-run-git-with-editor "notes" "prune" (and dry-run "--dry-run"))) + +;;; Readers + +(defun magit-notes-read-ref (prompt _initial-input history) + (and-let* ((ref (magit-completing-read + prompt (magit-list-notes-refnames) nil nil + (and-let* ((def (magit-get "core.notesRef"))) + (if (string-prefix-p "refs/notes/" def) + (substring def 11) + def)) + history))) + (if (string-prefix-p "refs/" ref) + ref + (concat "refs/notes/" ref)))) + +(defun magit-notes-read-refs (prompt &optional _initial-input _history) + (mapcar (lambda (ref) + (if (string-prefix-p "refs/" ref) + ref + (concat "refs/notes/" ref))) + (completing-read-multiple + (concat prompt ": ") + (magit-list-notes-refnames) nil nil + (mapconcat (lambda (ref) + (if (string-prefix-p "refs/notes/" ref) + (substring ref 11) + ref)) + (magit-get-all "notes.displayRef") + ",")))) + +(defun magit-notes-read-args (prompt) + (list (magit-read-branch-or-commit prompt (magit-stash-at-point)) + (and-let* ((str (seq-find (##string-match "^--ref=\\(.+\\)" %) + (transient-args 'magit-notes)))) + (match-string 1 str)))) + +;;; _ +(provide 'magit-notes) +;;; magit-notes.el ends here blob - /dev/null blob + 88641d514782792972ba0f7d104756b010abb865 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-patch.el @@ -0,0 +1,328 @@ +;;; magit-patch.el --- Creating and applying patches -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements patch commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-patch-save-arguments '(exclude "--stat") + "Control arguments used by the command `magit-patch-save'. + +`magit-patch-save' (which see) saves a diff for the changes +shown in the current buffer in a patch file. It may use the +same arguments as used in the buffer or a subset thereof, or +a constant list of arguments, depending on this option and +the prefix argument." + :package-version '(magit . "2.12.0") + :group 'magit-diff + :type '(choice (const :tag "Use buffer arguments" buffer) + (cons :tag "Use buffer arguments except" + (const :format "" exclude) + (repeat :format "%v%i\n" + (string :tag "Argument"))) + (repeat :tag "Use constant arguments" + (string :tag "Argument")))) + +;;; Commands + +;;;###autoload (autoload 'magit-patch "magit-patch" nil t) +(transient-define-prefix magit-patch () + "Create or apply patches." + ["Actions" + [("c" "Create patches" magit-patch-create) + ("w" "Apply patches" magit-am)] + [("a" "Apply plain patch" magit-patch-apply) + ("s" "Save diff as patch" magit-patch-save)] + [("r" "Request pull" magit-request-pull)]]) + +;;;###autoload (autoload 'magit-patch-create "magit-patch" nil t) +(transient-define-prefix magit-patch-create (range args files) + "Create patches for the commits in RANGE. +When a single commit is given for RANGE, create a patch for the +changes introduced by that commit (unlike 'git format-patch' +which creates patches for all commits that are reachable from +`HEAD' but not from the specified commit)." + :man-page "git-format-patch" + :incompatible '(("--subject-prefix=" "--rfc")) + ["Mail arguments" + (6 magit-format-patch:--in-reply-to) + (6 magit-format-patch:--thread) + (6 magit-format-patch:--from) + (6 magit-format-patch:--to) + (6 magit-format-patch:--cc)] + ["Patch arguments" + (magit-format-patch:--base) + (magit-format-patch:--reroll-count) + (5 magit-format-patch:--interdiff) + (magit-format-patch:--range-diff) + (magit-format-patch:--subject-prefix) + ("C-m r " "RFC subject prefix" "--rfc") + ("C-m l " "Add cover letter" "--cover-letter") + (5 magit-format-patch:--cover-from-description) + (5 magit-format-patch:--notes) + (magit-format-patch:--output-directory)] + ["Diff arguments" + (magit-diff:-U) + (magit-diff:-M) + (magit-diff:-C) + (magit-diff:--diff-algorithm) + (magit:--) + (7 "-b" "Ignore whitespace changes" ("-b" "--ignore-space-change")) + (7 "-w" "Ignore all whitespace" ("-w" "--ignore-all-space"))] + ["Actions" + ("c" "Create patches" magit-patch-create)] + (interactive + (if (not (eq transient-current-command 'magit-patch-create)) + (list nil nil nil) + (cons (if-let ((revs (magit-region-values 'commit t))) + (concat (car (last revs)) "^.." (car revs)) + (let ((range (magit-read-range-or-commit + "Create patches for range or commit"))) + (if (string-search ".." range) + range + (format "%s~..%s" range range)))) + (let ((args (transient-args 'magit-patch-create))) + (list (seq-filter #'stringp args) + (cdr (assoc "--" args))))))) + (if (not range) + (transient-setup 'magit-patch-create) + (magit-run-git "format-patch" range args "--" files) + (when (member "--cover-letter" args) + (save-match-data + (find-file + (expand-file-name + (concat (and-let* ((v (transient-arg-value "--reroll-count=" args))) + (format "v%s-" v)) + "0000-cover-letter.patch") + (let ((topdir (magit-toplevel))) + (if-let ((dir (transient-arg-value "--output-directory=" args))) + (expand-file-name dir topdir) + topdir)))))))) + +(transient-define-argument magit-format-patch:--in-reply-to () + :description "In reply to" + :class 'transient-option + :key "C-m C-r" + :argument "--in-reply-to=") + +(transient-define-argument magit-format-patch:--thread () + :description "Thread style" + :class 'transient-option + :key "C-m s " + :argument "--thread=" + :reader #'magit-format-patch-select-thread-style) + +(defun magit-format-patch-select-thread-style (&rest _ignore) + (magit-read-char-case "Thread style " t + (?d "[d]eep" "deep") + (?s "[s]hallow" "shallow"))) + +(transient-define-argument magit-format-patch:--base () + :description "Insert base commit" + :class 'transient-option + :key "C-m b " + :argument "--base=" + :reader #'magit-format-patch-select-base) + +(defun magit-format-patch-select-base (prompt initial-input history) + (or (magit-completing-read prompt (cons "auto" (magit-list-refnames)) + nil nil initial-input history "auto") + (user-error "Nothing selected"))) + +(transient-define-argument magit-format-patch:--reroll-count () + :description "Reroll count" + :class 'transient-option + :key "C-m v " + :shortarg "-v" + :argument "--reroll-count=" + :reader #'transient-read-number-N+) + +(transient-define-argument magit-format-patch:--interdiff () + :description "Insert interdiff" + :class 'transient-option + :key "C-m d i" + :argument "--interdiff=" + :reader #'magit-transient-read-revision) + +(transient-define-argument magit-format-patch:--range-diff () + :description "Insert range-diff" + :class 'transient-option + :key "C-m d r" + :argument "--range-diff=" + :reader #'magit-format-patch-select-range-diff) + +(defun magit-format-patch-select-range-diff (prompt _initial-input _history) + (magit-read-range-or-commit prompt)) + +(transient-define-argument magit-format-patch:--subject-prefix () + :description "Subject Prefix" + :class 'transient-option + :key "C-m p " + :argument "--subject-prefix=") + +(transient-define-argument magit-format-patch:--cover-from-description () + :description "Use branch description" + :class 'transient-option + :key "C-m D " + :argument "--cover-from-description=" + :reader #'magit-format-patch-select-description-mode) + +(defun magit-format-patch-select-description-mode (&rest _ignore) + (magit-read-char-case "Use description as " t + (?m "[m]essage" "message") + (?s "[s]ubject" "subject") + (?a "[a]uto" "auto") + (?n "[n]othing" "none"))) + +(transient-define-argument magit-format-patch:--notes () + :description "Insert commentary from notes" + :class 'transient-option + :key "C-m n " + :argument "--notes=" + :reader #'magit-notes-read-ref) + +(transient-define-argument magit-format-patch:--from () + :description "From" + :class 'transient-option + :key "C-m C-f" + :argument "--from=" + :reader #'magit-transient-read-person) + +(transient-define-argument magit-format-patch:--to () + :description "To" + :class 'transient-option + :key "C-m C-t" + :argument "--to=" + :reader #'magit-transient-read-person) + +(transient-define-argument magit-format-patch:--cc () + :description "CC" + :class 'transient-option + :key "C-m C-c" + :argument "--cc=" + :reader #'magit-transient-read-person) + +(transient-define-argument magit-format-patch:--output-directory () + :description "Output directory" + :class 'transient-option + :key "C-m o " + :shortarg "-o" + :argument "--output-directory=" + :reader #'transient-read-existing-directory) + +;;;###autoload (autoload 'magit-patch-apply "magit-patch" nil t) +(transient-define-prefix magit-patch-apply (file &rest args) + "Apply the patch file FILE." + :man-page "git-apply" + ["Arguments" + ("-i" "Also apply to index" "--index") + ("-c" "Only apply to index" "--cached") + ("-3" "Fall back on 3way merge" ("-3" "--3way"))] + ["Actions" + ("a" "Apply patch" magit-patch-apply)] + (interactive + (if (not (eq transient-current-command 'magit-patch-apply)) + (list nil) + (list (expand-file-name + (read-file-name "Apply patch: " + default-directory nil nil + (and-let* ((file (magit-file-at-point))) + (file-relative-name file)))) + (transient-args 'magit-patch-apply)))) + (if (not file) + (transient-setup 'magit-patch-apply) + (magit-run-git "apply" args "--" (magit-convert-filename-for-git file)))) + +;;;###autoload +(defun magit-patch-save (file &optional arg) + "Write current diff into patch FILE. + +What arguments are used to create the patch depends on the value +of `magit-patch-save-arguments' and whether a prefix argument is +used. + +If the value is the symbol `buffer', then use the same arguments +as the buffer. With a prefix argument use no arguments. + +If the value is a list beginning with the symbol `exclude', then +use the same arguments as the buffer except for those matched by +entries in the cdr of the list. The comparison is done using +`string-prefix-p'. With a prefix argument use the same arguments +as the buffer. + +If the value is a list of strings (including the empty list), +then use those arguments. With a prefix argument use the same +arguments as the buffer. + +Of course the arguments that are required to actually show the +same differences as those shown in the buffer are always used." + (interactive (list (read-file-name "Write patch file: " default-directory) + current-prefix-arg)) + (unless (derived-mode-p 'magit-diff-mode) + (user-error "Only diff buffers can be saved as patches")) + (let ((rev magit-buffer-range) + (typearg magit-buffer-typearg) + (args magit-buffer-diff-args) + (files magit-buffer-diff-files)) + (cond ((eq magit-patch-save-arguments 'buffer) + (when arg + (setq args nil))) + ((eq (car-safe magit-patch-save-arguments) 'exclude) + (unless arg + (setq args + (cl-set-difference args (cdr magit-patch-save-arguments) + :test #'equal)))) + ((not arg) + (setq args magit-patch-save-arguments))) + (with-temp-file file + (magit-git-insert "diff" rev "-p" typearg args "--" files))) + (magit-refresh)) + +;;;###autoload +(defun magit-request-pull (url start end) + "Request upstream to pull from your public repository. + +URL is the url of your publicly accessible repository. +START is a commit that already is in the upstream repository. +END is the last commit, usually a branch name, which upstream +is asked to pull. START has to be reachable from that commit." + (interactive + (list (magit-get "remote" (magit-read-remote "Remote") "url") + (magit-read-branch-or-commit "Start" (magit-get-upstream-branch)) + (magit-read-branch-or-commit "End"))) + (let ((dir default-directory)) + ;; mu4e changes default-directory + (compose-mail) + (setq default-directory dir)) + (message-goto-body) + (magit-git-insert "request-pull" start url end) + (set-buffer-modified-p nil)) + +;;; _ +(provide 'magit-patch) +;;; magit-patch.el ends here blob - /dev/null blob + 10d69cfd3b0bfb661afad0619cc0c6c4d8fb8932 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from magit.el -*- no-byte-compile: t -*- +(define-package "magit" "4.3.8" "A Git porcelain inside Emacs" '((emacs "27.1") (compat "30.1") (llama "1.0.0") (magit-section "4.3.8") (seq "2.24") (transient "0.9.3") (with-editor "3.4.4")) :commit "5b820a1d1e94649e0f218362286d520d9f29ac2c" :authors '(("Marius Vollmer" . "marius.vollmer@gmail.com") ("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) :maintainer '(("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") ("Kyle Meyer" . "kyle@kyleam.com")) :keywords '("git" "tools" "vc") :url "https://github.com/magit/magit") blob - /dev/null blob + fcc4b30370e7cc5695b77018cbcac7faf0ae29d1 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-process.el @@ -0,0 +1,1346 @@ +;;; magit-process.el --- Process functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements the tools used to run Git for side-effects. + +;; Note that the functions used to run Git and then consume its +;; output, are defined in `magit-git.el'. There's a bit of overlap +;; though. + +;;; Code: + +(require 'magit-base) +(require 'magit-git) +(require 'magit-mode) + +(require 'ansi-color) +(require 'auth-source) +(require 'with-editor) + +(defvar messages-buffer-name) +(defvar y-or-n-p-map) + +(define-obsolete-variable-alias 'magit-process-finish-apply-ansi-colors + 'magit-process-apply-ansi-colors "Magit-Section 4.3.2") + +(defclass magit-process-section (magit-section) + ((process :initform nil))) + +;;; Options + +(defcustom magit-process-connection-type (not (eq system-type 'cygwin)) + "Connection type used for the Git process. + +If nil, use pipes: this is usually more efficient, and works on Cygwin. +If t, use ptys: this enables Magit to prompt for passphrases when needed." + :group 'magit-process + :type '(choice (const :tag "Pipe" nil) + (const :tag "Pty" t))) + +(defcustom magit-need-cygwin-noglob + (and (eq system-type 'windows-nt) + (with-temp-buffer + (let ((process-environment + (append magit-git-environment process-environment))) + (condition-case e + (process-file magit-git-executable + nil (current-buffer) nil + "-c" "alias.echo=!echo" "echo" "x{0}") + (file-error + (lwarn 'magit-process :warning + "Could not run Git: %S" e)))) + (equal "x0\n" (buffer-string)))) + "Whether to use a workaround for Cygwin's globbing behavior. + +If non-nil, add environment variables to `process-environment' to +prevent the git.exe distributed by Cygwin and MSYS2 from +attempting to perform glob expansion when called from a native +Windows build of Emacs. See #2246." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom magit-process-popup-time -1 + "Popup the process buffer if a command takes longer than this many seconds." + :group 'magit-process + :type '(choice (const :tag "Never" -1) + (const :tag "Immediately" 0) + (integer :tag "After this many seconds"))) + +(defcustom magit-process-log-max 32 + "Maximum number of sections to keep in a process log buffer. +When adding a new section would go beyond the limit set here, +then the older half of the sections are remove. Sections that +belong to processes that are still running are never removed. +When this is nil, no sections are ever removed." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type '(choice (const :tag "Never remove old sections" nil) integer)) + +(defcustom magit-process-error-tooltip-max-lines 20 + "The number of lines for `magit-process-error-lines' to return. + +These are displayed in a tooltip for `mode-line-process' errors. + +If `magit-process-error-tooltip-max-lines' is nil, the tooltip +displays the text of `magit-process-error-summary' instead." + :package-version '(magit . "2.12.0") + :group 'magit-process + :type '(choice (const :tag "Use summary line" nil) + integer)) + +(defcustom magit-credential-cache-daemon-socket + (seq-some (lambda (line) + (pcase-let ((`(,prog . ,args) (split-string line))) + (and prog + (string-match-p + "\\`\\(?:\\(?:/.*/\\)?git-credential-\\)?cache\\'" prog) + (or (cadr (member "--socket" args)) + (expand-file-name "~/.git-credential-cache/socket"))))) + ;; Note: `magit-process-file' is not yet defined when + ;; evaluating this form, so we use `process-lines'. + (ignore-errors + (let ((process-environment + (append magit-git-environment process-environment))) + (process-lines magit-git-executable + "config" "--get-all" "credential.helper")))) + "If non-nil, start a credential cache daemon using this socket. + +When using Git's cache credential helper in the normal way, Emacs +sends a SIGHUP to the credential daemon after the git subprocess +has exited, causing the daemon to also quit. This can be avoided +by starting the `git-credential-cache--daemon' process directly +from Emacs. + +The function `magit-maybe-start-credential-cache-daemon' takes +care of starting the daemon if necessary, using the value of this +option as the socket. If this option is nil, then it does not +start any daemon. Likewise if another daemon is already running, +then it starts no new daemon. This function has to be a member +of the hook variable `magit-credential-hook' for this to work. +If an error occurs while starting the daemon, most likely because +the necessary executable is missing, then the function removes +itself from the hook, to avoid further futile attempts." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type '(choice (file :tag "Socket") + (const :tag "Don't start a cache daemon" nil))) + +(defcustom magit-process-yes-or-no-prompt-regexp + (eval-when-compile + (concat " [([]" + "\\([Yy]\\(?:es\\)?\\)" + "[/|]" + "\\([Nn]o?\\)" + ;; OpenSSH v8 prints this. See #3969. + "\\(?:/\\[fingerprint\\]\\)?" + "[])] ?[?:]? ?$")) + "Regexp matching Yes-or-No prompts of Git and its subprocesses." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type 'regexp) + +(defcustom magit-process-password-prompt-regexps + ;; See also history in test `magit-process:password-prompt-regexps'. + '(;; * CLI-prompt for passphrase for key: + "^\\(\\(Please e\\|E\\)nter \\(the \\)?p\\|P\\)assphrase.*: ?$" + ;; * Password for something other than a host: + "^\\(\\(Please e\\|E\\)nter \\(the \\)?p\\|P\\)assword: ?$" + ;; * Password for [user@]host (which we put in match group 99): + "^\\(\\(Please e\\|E\\)nter \\(the \\)?p\\|P\\)assword for \ +[\"']?\\(https?://\\)?\\(?99:[^\"']+\\)[\"']?: ?$" + "^(\\(?1:[^) ]+\\)) Password for \\(?99:\\1\\): ?$" ;#4992 + "^\\(?99:[^']+\\)\\('s\\)? password: ?$" + ;; * Token for git-credential-manager-core (#4318): + "^Token: ?$" + ;; * Secret for card: + "^Yubikey for .*: ?$" + "^Enter PIN for .*: ?$" + ;; * Unanchored TUI-prompt for passphrase for key: + "Please enter the passphrase for the ssh key" + "Please enter the passphrase to unlock the OpenPGP secret key") + "List of regexps matching password prompts of Git and its subprocesses. +Also see `magit-process-find-password-functions'." + :package-version '(magit . "4.3.0") + :group 'magit-process + :type '(repeat (regexp))) + +(defcustom magit-process-find-password-functions nil + "List of functions to try in sequence to get a password. + +These functions may be called when git asks for a password, which +is detected using `magit-process-password-prompt-regexps'. They +are called if and only if matching the prompt resulted in the +value of the 99th submatch to be non-nil. Therefore users can +control for which prompts these functions should be called by +putting the host name in the 99th submatch, or not. + +If the functions are called, then they are called in the order +given, with the host name as only argument, until one of them +returns non-nil. If they are not called or none of them returns +non-nil, then the password is read from the user instead." + :package-version '(magit . "2.3.0") + :group 'magit-process + :type 'hook + :options (list #'magit-process-password-auth-source)) + +(defcustom magit-process-username-prompt-regexps + '("^Username for '.*': ?$") + "List of regexps matching username prompts of Git and its subprocesses." + :package-version '(magit . "2.1.0") + :group 'magit-process + :type '(repeat (regexp))) + +(defcustom magit-process-prompt-functions nil + "List of functions used to forward arbitrary questions to the user. + +Magit has dedicated support for forwarding username and password +prompts and Yes-or-No questions asked by Git and its subprocesses +to the user. This can be customized using other options in the +`magit-process' customization group. + +If you encounter a new question that isn't handled by default, +then those options should be used instead of this hook. + +However subprocesses may also ask questions that differ too much +from what the code related to the above options assume, and this +hook allows users to deal with such questions explicitly. + +Each function is called with the process and the output string +as arguments until one of the functions returns non-nil. The +function is responsible for asking the user the appropriate +question using, e.g., `read-char-choice' and then forwarding the +answer to the process using `process-send-string'. + +While functions such as `magit-process-yes-or-no-prompt' may not +be sufficient to handle some prompt, it may still be of benefit +to look at the implementations to gain some insights on how to +implement such functions." + :package-version '(magit . "3.0.0") + :group 'magit-process + :type 'hook) + +(defcustom magit-process-ensure-unix-line-ending t + "Whether Magit should ensure a unix coding system when talking to Git." + :package-version '(magit . "2.6.0") + :group 'magit-process + :type 'boolean) + +(defcustom magit-process-display-mode-line-error t + "Whether Magit should retain and highlight process errors in the mode line. + +See `magit-show-process-buffer-hint' for another way to display the +complete output on demand." + :package-version '(magit . "2.12.0") + :group 'magit-process + :type 'boolean) + +(defcustom magit-show-process-buffer-hint t + "Whether to append hint about process buffer to Git error messages. + +When Magit runs Git for side-effects, the output is always logged to +a per-repository process buffer. If Git exits with a non-zero status, +then a single line of its error output is shown in the repositories +status buffer and in the echo area. + +When a user want to learn more about the error, they can switch to that +process buffer, to see the complete output, but initially users are not +aware of this, so Magit appends a usage hint to the error message in +both of these places. + +Once you are aware of this, you probably won't need the reminder and can +set this option to nil. + +See `magit-process-display-mode-line-error' for another way to display +the complete output on demand." + :package-version '(magit . "4.3.7") + :group 'magit-process + :type 'boolean) + +(defcustom magit-process-apply-ansi-colors nil + "Whether and when to apply color escapes in the process buffer. + +Magit instructs Git to not colorize its output, but third-party Git +hooks may do so anyway. We recommend you figure out how to prevent +such hooks from colorizing their output instead of customizing this +option. + +If `nil' (the default), do not apply color escape sequences. If `t', +apply them once the subprocess has finished. If `filter', apply them +as input arrives (which is more expensive and potentially fragile). +This is a footgun; starter-kits should leave this option untouched." + :package-version '(magit . "4.3.2") + :group 'magit-process + :type '(choice (const :tag "Do not apply" nil) + (const :tag "Apply when subprocess has finished" t) + (const :tag "Apply using process filter" filter))) + +(defcustom magit-process-timestamp-format nil + "Format of timestamp for each process in the process buffer. +If non-nil, pass this to `format-time-string' when creating a +process section in the process buffer, and insert the returned +string in the heading of its section." + :package-version '(magit . "4.0.0") + :group 'magit-process + :type '(choice (const :tag "None" nil) string)) + +(defvar tramp-pipe-stty-settings) +(defvar magit-tramp-pipe-stty-settings "" + "Override `tramp-pipe-stty-settings' in `magit-start-process'. + +The default for that Tramp variable is \"-icanon min 1 time 0\", +which causes staging of individual hunks to hang. Using \"\" +prevents that, but apparently has other issues, which is why it +isn't the default. + +This variable defaults to \"\" and is used to override the Tramp +variable in `magit-start-process'. This only has an effect when +using Tramp 2.6.2 or greater. This can also be set to `pty', in +which case a pty is used instead of a pipe. That also prevents +the hanging, but doesn't work for files with DOS line endings +\(see #20). + +For connections that have `tramp-direct-async-process' enabled, +staging hunks hangs, unless this variable is set to `pty' (see +#5220). + +To fall back to the value of `tramp-pipe-stty-settings', set this +variable to nil. + +Also see https://github.com/magit/magit/issues/4720 +and https://debbugs.gnu.org/cgi/bugreport.cgi?bug=62093.") + +(defface magit-process-ok + '((t :inherit magit-section-heading :foreground "green")) + "Face for zero exit-status." + :group 'magit-faces) + +(defface magit-process-ng + '((t :inherit magit-section-heading :foreground "red")) + "Face for non-zero exit-status." + :group 'magit-faces) + +(defface magit-mode-line-process + '((t :inherit mode-line-emphasis)) + "Face for `mode-line-process' status when Git is running for side-effects." + :group 'magit-faces) + +(defface magit-mode-line-process-error + '((t :inherit error)) + "Face for `mode-line-process' error status. + +Used when `magit-process-display-mode-line-error' is non-nil." + :group 'magit-faces) + +;;; Process Mode + +(defvar-keymap magit-process-mode-map + :doc "Keymap for `magit-process-mode'." + :parent magit-mode-map + " " #'undefined + " " #'magit-process-kill) + +(define-derived-mode magit-process-mode magit-mode "Magit Process" + "Mode for looking at Git process output." + :interactive nil + :group 'magit-process + (magit-hack-dir-local-variables) + (setq magit--imenu-item-types 'process)) + +(defun magit-process-buffer (&optional nodisplay) + "Display the current repository's process buffer. + +If that buffer doesn't exist yet, then create it. +Non-interactively return the buffer and unless +optional NODISPLAY is non-nil also display it." + (interactive) + (let ((topdir (magit-toplevel))) + (unless topdir + (magit--with-safe-default-directory nil + (setq topdir default-directory) + (let (prev) + (while (not (equal topdir prev)) + (setq prev topdir) + (setq topdir (file-name-directory (directory-file-name topdir))))))) + (let ((buffer (or (seq-find (##with-current-buffer % + (and (eq major-mode 'magit-process-mode) + (equal default-directory topdir))) + (buffer-list)) + (magit-generate-new-buffer 'magit-process-mode + nil topdir)))) + (with-current-buffer buffer + (if magit-root-section + (when magit-process-log-max + (magit-process-truncate-log)) + (magit-process-mode) + (let ((inhibit-read-only t) + (magit-insert-section--parent nil) + (magit-insert-section--oldroot nil)) + (make-local-variable 'text-property-default-nonsticky) + (magit-insert-section (processbuf) + (insert "\n"))))) + (unless nodisplay + (magit-display-buffer buffer)) + buffer))) + +(defun magit-process-kill () + "Kill the process at point." + (interactive) + (when-let ((process (magit-section-value-if 'process))) + (unless (eq (process-status process) 'run) + (user-error "Process isn't running")) + (magit-confirm 'kill-process) + (kill-process process))) + +;;; Synchronous Processes + +(defvar magit-process-raise-error nil) + +(defvar magit-process-record-invocations nil) +(defvar magit-process-record-buffer-name " *magit-process-file record*") +(defvar magit-process-record-entry-format "%T %%d $ %%a") + +(defun magit-toggle-subprocess-record () + "Toggle whether subprocess invocations are recorded. + +When enabled, all subprocesses started by `magit-process-file' are +logged into the buffer specified by `magit-process-record-buffer-name' +using the format `magit-process-record-entry-format'. This is for +debugging purposes. + +This is in addition to and distinct from the default logging done by +default, and additional logging enabled with ~magit-toggle-git-debug~. + +For alternatives, see info node `(magit)Debugging Tools'." + (interactive) + (setq magit-process-record-invocations (not magit-process-record-invocations)) + (message "Recording of subprocess invocations %s" + (if magit-process-record-invocations "enabled" "disabled"))) + +(defun magit-git (&rest args) + "Call Git synchronously in a separate process, for side-effects. + +Option `magit-git-executable' specifies the Git executable. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'. If Git exits with a non-zero status, +then raise an error." + (let ((magit-process-raise-error t)) + (magit-call-git args))) + +(defun magit-run-git (&rest args) + "Call Git synchronously in a separate process, and refresh. + +Function `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +After Git returns, the current buffer (if it is a Magit buffer) +as well as the current repository's status buffer are refreshed. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (let ((magit--refresh-cache (list (cons 0 0)))) + (prog1 (magit-call-git args) + (when (member (car args) '("init" "clone")) + ;; Creating a new repository invalidates the cache. + (setq magit--refresh-cache nil)) + (magit-refresh)))) + +(defvar magit-pre-call-git-hook (list #'magit-maybe-save-repository-buffers)) + +(defun magit-call-git (&rest args) + "Call Git synchronously in a separate process. + +Function `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The arguments ARGS specify arguments to Git, they are flattened +before use. + +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (run-hooks 'magit-pre-call-git-hook) + (let ((default-process-coding-system (magit--process-coding-system))) + (apply #'magit-call-process + (magit-git-executable) + (magit-process-git-arguments args)))) + +(defun magit-call-process (program &rest args) + "Call PROGRAM synchronously in a separate process. +Process output goes into a new section in the buffer returned by +`magit-process-buffer'." + (pcase-let ((`(,process-buf . ,section) + (magit-process-setup program args))) + (magit-process-finish + (let ((inhibit-read-only t)) + (apply #'magit-process-file program nil process-buf nil args)) + process-buf (current-buffer) default-directory section))) + +(defun magit-process-git (destination &rest args) + "Call Git synchronously in a separate process, returning its exit code. +DESTINATION specifies how to handle the output, like for +`call-process', except that file handlers are supported. +Enable Cygwin's \"noglob\" option during the call and +ensure unix eol conversion." + (apply #'magit-process-file + (magit-git-executable) + nil destination nil + (magit-process-git-arguments args))) + +(defun magit-process-file (process &optional infile buffer display &rest args) + "Process files synchronously in a separate process. +Similar to `process-file' but temporarily enable Cygwin's +\"noglob\" option during the call and ensure unix eol conversion." + (when magit-process-record-invocations + (let ((messages-buffer-name magit-process-record-buffer-name) + (inhibit-message t)) + (message "%s" + (format-spec + (format-time-string magit-process-record-entry-format) + `((?d . ,(abbreviate-file-name default-directory)) + (?a . ,(magit-process--format-arguments process args))))))) + (let ((process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system))) + (apply #'process-file process infile buffer display args))) + +(defun magit-process-environment () + ;; The various w32 hacks are only applicable when running on the local + ;; machine. A local binding of process-environment different from the + ;; top-level value affects the environment used by Tramp. + (let ((local (not (file-remote-p default-directory)))) + (append magit-git-environment + (and local + (cdr (assoc magit-git-executable magit-git-w32-path-hack))) + (and local magit-need-cygwin-noglob + (mapcar (lambda (var) + (concat var "=" (if-let ((val (getenv var))) + (concat val " noglob") + "noglob"))) + '("CYGWIN" "MSYS"))) + process-environment))) + +(defvar magit-this-process nil) + +(defun magit-run-git-with-input (&rest args) + "Call Git in a separate process. +ARGS is flattened and then used as arguments to Git. + +The current buffer's content is used as the process's standard +input. The buffer is assumed to be temporary and thus OK to +modify. + +Function `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The remaining arguments ARGS specify arguments to Git, they are +flattened before use." + (when (eq system-type 'windows-nt) + ;; On w32, git expects UTF-8 encoded input, ignore any user + ;; configuration telling us otherwise (see #3250). + (encode-coding-region (point-min) (point-max) 'utf-8-unix)) + (if (file-remote-p default-directory) + ;; We lack `process-file-region', so fall back to asynch + + ;; waiting in remote case. + (progn + (magit-start-git (current-buffer) args) + (while (and magit-this-process + (eq (process-status magit-this-process) 'run)) + (sleep-for 0.005))) + (run-hooks 'magit-pre-call-git-hook) + (pcase-let* ((process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system)) + (flat-args (magit-process-git-arguments args)) + (`(,process-buf . ,section) + (magit-process-setup (magit-git-executable) flat-args)) + (inhibit-read-only t)) + (magit-process-finish + (apply #'call-process-region (point-min) (point-max) + (magit-git-executable) nil process-buf nil flat-args) + process-buf nil default-directory section)))) + +;;; Asynchronous Processes + +(defun magit-run-git-async (&rest args) + "Start Git, prepare for refresh, and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' for more information." + (magit-msg "Running %s %s" (magit-git-executable) + (let ((m (string-join (flatten-tree args) " "))) + (remove-list-of-text-properties 0 (length m) '(face) m) + m)) + (magit-start-git nil args)) + +(defun magit-run-git-with-editor (&rest args) + "Export GIT_EDITOR and start Git. +Also prepare for refresh and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' and `with-editor' for more information." + (magit--record-separated-gitdir) + (magit-with-editor (magit-run-git-async args))) + +(defun magit-run-git-sequencer (&rest args) + "Export GIT_EDITOR and start Git. +Also prepare for refresh and return the process object. +ARGS is flattened and then used as arguments to Git. + +Display the command line arguments in the echo area. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. +If the sequence stops at a commit, make the section representing +that commit the current section by moving `point' there. + +See `magit-start-process' and `with-editor' for more information." + (apply #'magit-run-git-with-editor args) + (set-process-sentinel magit-this-process #'magit-sequencer-process-sentinel) + magit-this-process) + +(defvar magit-pre-start-git-hook (list #'magit-maybe-save-repository-buffers)) + +(defun magit-start-git (input &rest args) + "Start Git, prepare for refresh, and return the process object. + +If INPUT is non-nil, it has to be a buffer or the name of an +existing buffer. The buffer content becomes the processes +standard input. + +Function `magit-git-executable' specifies the Git executable and +option `magit-git-global-arguments' specifies constant arguments. +The remaining arguments ARGS specify arguments to Git, they are +flattened before use. + +After Git returns some buffers are refreshed: the buffer that was +current when this function was called (if it is a Magit buffer +and still alive), as well as the respective Magit status buffer. + +See `magit-start-process' for more information." + (run-hooks 'magit-pre-start-git-hook) + (let ((default-process-coding-system (magit--process-coding-system))) + (apply #'magit-start-process (magit-git-executable) input + (magit-process-git-arguments args)))) + +(defun magit-start-process (program &optional input &rest args) + "Start PROGRAM, prepare for refresh, and return the process object. + +If optional argument INPUT is non-nil, it has to be a buffer or +the name of an existing buffer. The buffer content becomes the +processes standard input. + +The process is started using `start-file-process' and then setup +to use the sentinel `magit-process-sentinel' and the filter +`magit-process-filter'. Information required by these functions +is stored in the process object. When this function returns the +process has not started to run yet so it is possible to override +the sentinel and filter. + +After the process returns, `magit-process-sentinel' refreshes the +buffer that was current when `magit-start-process' was called (if +it is a Magit buffer and still alive), as well as the respective +Magit status buffer." + (pcase-let* + ((`(,process-buf . ,section) + (magit-process-setup program args)) + (process + (let ((process-connection-type ;t=pty nil=pipe + (or + ;; With Tramp, maybe force use a pty. #4720 + (and (file-remote-p default-directory) + (eq magit-tramp-pipe-stty-settings 'pty)) + ;; Without input, don't use a pty, because it would + ;; set icrnl, which would modify the input. #20 + (and (not input) magit-process-connection-type))) + (tramp-pipe-stty-settings + (or (and (not (eq magit-tramp-pipe-stty-settings 'pty)) + ;; Defaults to "", to allow staging hunks over + ;; Tramp again. #4720 + magit-tramp-pipe-stty-settings) + (bound-and-true-p tramp-pipe-stty-settings))) + (process-environment (magit-process-environment)) + (default-process-coding-system (magit--process-coding-system))) + (apply #'start-file-process + (file-name-nondirectory program) + process-buf program args)))) + (with-editor-set-process-filter process #'magit-process-filter) + (set-process-sentinel process #'magit-process-sentinel) + (set-process-buffer process process-buf) + (when (eq system-type 'windows-nt) + ;; On w32, git expects UTF-8 encoded input, ignore any user + ;; configuration telling us otherwise. + (set-process-coding-system process nil 'utf-8-unix)) + (process-put process 'section section) + (process-put process 'command-buf (current-buffer)) + (process-put process 'default-dir default-directory) + (when magit-inhibit-refresh + (process-put process 'inhibit-refresh t)) + (oset section process process) + (with-current-buffer process-buf + (set-marker (process-mark process) (point))) + (when input + (with-current-buffer input + (process-send-region process (point-min) (point-max)) + ;; `process-send-eof' appears to be broken over + ;; Tramp from Windows. See #3624 and bug#43226. + (if (and (eq system-type 'windows-nt) + (file-remote-p (process-get process 'default-dir) nil t)) + (process-send-string process "") + (process-send-eof process)))) + (setq magit-this-process process) + (oset section value process) + (magit-process-display-buffer process) + process)) + +(defun magit-parse-git-async (&rest args) + (setq args (magit-process-git-arguments args)) + (let ((command-buf (current-buffer)) + (stdout-buf (generate-new-buffer " *git-stdout*")) + (stderr-buf (generate-new-buffer " *git-stderr*")) + (toplevel (magit-toplevel))) + (with-current-buffer stdout-buf + (setq default-directory toplevel) + (let ((process + (let ((process-environment (magit-process-environment))) + (make-process :name "git" + :buffer stdout-buf + :stderr stderr-buf + :command (cons (magit-git-executable) args) + :coding (magit--process-coding-system) + :file-handler t)))) + (process-put process 'command-buf command-buf) + (process-put process 'stderr-buf stderr-buf) + (process-put process 'parsed (point)) + (setq magit-this-process process) + process)))) + +;;; Process Internals + +(setf (alist-get 'process magit--section-type-alist) 'magit-process-section) + +(defun magit-process-setup (program args) + (magit-process-set-mode-line program args) + (let ((pwd default-directory) + (buf (magit-process-buffer t))) + (cons buf (with-current-buffer buf + (prog1 (magit-process-insert-section pwd program args nil nil) + (backward-char 1)))))) + +(defun magit-process-insert-section + (pwd program args &optional errcode errlog face) + (let ((inhibit-read-only t) + (magit-insert-section--current nil) + (magit-insert-section--parent magit-root-section) + (magit-insert-section--oldroot nil)) + (goto-char (1- (point-max))) + (magit-insert-section (process) + (insert (if errcode + (format "%3s " (propertize (number-to-string errcode) + 'font-lock-face 'magit-process-ng)) + "run ")) + (when magit-process-timestamp-format + (insert (format-time-string magit-process-timestamp-format) " ")) + (let ((cmd (concat + (and (not (equal + (file-name-as-directory (expand-file-name pwd)) + (file-name-as-directory (expand-file-name + default-directory)))) + (concat (file-relative-name pwd default-directory) " ")) + (magit-process--format-arguments program args)))) + (magit-insert-heading (if face (propertize cmd 'face face) cmd))) + (when errlog + (if (bufferp errlog) + (insert (with-current-buffer errlog + (buffer-substring-no-properties (point-min) (point-max)))) + (insert-file-contents errlog) + (goto-char (1- (point-max))))) + (insert "\n")))) + +(defun magit-process--format-arguments (program args) + (cond + ((and args (equal program (magit-git-executable))) + (let ((global (length magit-git-global-arguments))) + (concat + (propertize (file-name-nondirectory program) + 'font-lock-face 'magit-section-heading) + " " + (propertize (magit--ellipsis) + 'font-lock-face 'magit-section-heading + 'help-echo (string-join (seq-take args global) " ")) + " " + (propertize (mapconcat #'shell-quote-argument (seq-drop args global) " ") + 'font-lock-face 'magit-section-heading)))) + ((and args (equal program shell-file-name)) + (propertize (cadr args) + 'font-lock-face 'magit-section-heading)) + (t + (concat (propertize (file-name-nondirectory program) + 'font-lock-face 'magit-section-heading) + " " + (propertize (mapconcat #'shell-quote-argument args " ") + 'font-lock-face 'magit-section-heading))))) + +(defun magit-process-truncate-log () + (let* ((head nil) + (tail (oref magit-root-section children)) + (count (length tail))) + (when (> (1+ count) magit-process-log-max) + (while (and (cdr tail) + (> count (/ magit-process-log-max 2))) + (let* ((inhibit-read-only t) + (section (car tail)) + (process (oref section process))) + (cond ((not process)) + ((memq (process-status process) '(exit signal)) + (delete-region (oref section start) + (1+ (oref section end))) + (cl-decf count)) + (t + (push section head)))) + (pop tail)) + (oset magit-root-section children + (nconc (reverse head) tail))))) + +(defun magit-process-sentinel (process event) + "Default sentinel used by `magit-start-process'." + (when (memq (process-status process) '(exit signal)) + (setq event (substring event 0 -1)) + (when (string-match "^finished" event) + (message (concat (capitalize (process-name process)) " finished"))) + (magit-process-finish process) + (when (eq process magit-this-process) + (setq magit-this-process nil)) + (unless (process-get process 'inhibit-refresh) + (let ((command-buf (process-get process 'command-buf))) + (if (buffer-live-p command-buf) + (with-current-buffer command-buf + (magit-refresh)) + (with-temp-buffer + (setq default-directory (process-get process 'default-dir)) + (magit-refresh))))))) + +(defun magit-sequencer-process-sentinel (process event) + "Special sentinel used by `magit-run-git-sequencer'." + (when (memq (process-status process) '(exit signal)) + (magit-process-sentinel process event) + (when-let* ((process-buf (process-buffer process)) + ((buffer-live-p process-buf)) + (status-buf (with-current-buffer process-buf + (magit-get-mode-buffer 'magit-status-mode)))) + (with-current-buffer status-buf + (when-let ((section + (magit-get-section + `((commit . ,(magit-rev-parse "HEAD")) + (,(pcase (car (seq-drop + (process-command process) + (1+ (length magit-git-global-arguments)))) + ((or "rebase" "am") 'rebase-sequence) + ((or "cherry-pick" "revert") 'sequence))) + (status))))) + (goto-char (oref section start)) + (magit-section-update-highlight)))))) + +(defun magit-process-filter (proc string) + "Default filter used by `magit-start-process'." + (with-current-buffer (process-buffer proc) + (let ((inhibit-read-only t)) + (goto-char (process-mark proc)) + ;; Find last ^M in string. If one was found, ignore + ;; everything before it and delete the current line. + (when-let ((ret-pos (cl-position ?\r string :from-end t))) + (setq string (substring string (1+ ret-pos))) + (delete-region (line-beginning-position) (point))) + (setq string (magit-process-remove-bogus-errors string)) + (when (eq magit-process-apply-ansi-colors 'filter) + (setq string (ansi-color-apply string))) + (insert (propertize string 'magit-section + (process-get proc 'section))) + (set-marker (process-mark proc) (point)) + ;; Make sure prompts are matched after removing ^M. + (magit-process-yes-or-no-prompt proc string) + (magit-process-username-prompt proc string) + (magit-process-password-prompt proc string) + (run-hook-with-args-until-success 'magit-process-prompt-functions + proc string)))) + +(defun magit-process-make-keymap (process parent) + "Remap `abort-minibuffers' to a command that also kills PROCESS. +PARENT is used as the parent of the returned keymap." + (let ((cmd (lambda () + (interactive) + (ignore-errors (kill-process process)) + (if (fboundp 'abort-minibuffers) + (abort-minibuffers) + (abort-recursive-edit))))) + (define-keymap :parent parent + "C-g" cmd + " " cmd + " " cmd))) + +(defmacro magit-process-kill-on-abort (process &rest body) + (declare (indent 1) + (debug (form body)) + (obsolete magit-process-make-keymap "Magit 4.0.0")) + `(let ((minibuffer-local-map + (magit-process-make-keymap ,process minibuffer-local-map))) + ,@body)) + +(defun magit-process-remove-bogus-errors (str) + (save-match-data + (when (string-match "^\\(\\*ERROR\\*: \\)Canceled by user" str) + (setq str (replace-match "" nil nil str 1))) + (when (string-match "^error: There was a problem with the editor.*\n" str) + (setq str (replace-match "" nil nil str))) + (when (string-match + "^Please supply the message using either -m or -F option\\.\n" str) + (setq str (replace-match "" nil nil str)))) + str) + +(defun magit-process-yes-or-no-prompt (process string) + "Forward Yes-or-No prompts to the user." + (when-let ((beg (string-match magit-process-yes-or-no-prompt-regexp string))) + (process-send-string + process + (if (save-match-data + (let ((max-mini-window-height 30) + (minibuffer-local-map + (magit-process-make-keymap process minibuffer-local-map)) + ;; In case yes-or-no-p is fset to that, but does + ;; not cover use-dialog-box-p and y-or-n-p-read-key. + (y-or-n-p-map + (magit-process-make-keymap process y-or-n-p-map))) + (yes-or-no-p (substring string 0 beg)))) + (concat (downcase (match-string 1 string)) "\n") + (concat (downcase (match-string 2 string)) "\n"))))) + +(defun magit-process-password-auth-source (key) + "Use `auth-source-search' to get a password. +If found, return the password. Otherwise, return nil. + +KEY typically derives from a prompt such as: + Password for \\='https://yourname@github.com\\=' +in which case it would be the string + yourname@github.com +which matches the ~/.authinfo.gpg entry + machine github.com login yourname password 12345 +or iff that is undefined, for backward compatibility + machine yourname@github.com password 12345 + +On github.com you should not use your password but a +personal access token, see [1]. For information about +the peculiarities of other forges, please consult the +respective documentation. + +After manually editing ~/.authinfo.gpg you must reset +the cache using + \\`M-x' `auth-source-forget-all-cached' \\`RET' + +The above will save you from having to repeatedly type +your token or password, but you might still repeatedly +be asked for your username. To prevent that, change an +URL like + https://github.com/foo/bar.git +to + https://yourname@github.com/foo/bar.git + +Instead of changing all such URLs manually, they can +be translated on the fly by doing this once + git config --global \ + url.https://yourname@github.com.insteadOf \ + https://github.com + +[1]: https://docs.github.com/en/github/authenticating-to-github/creating-a-personal-access-token." + (require 'auth-source) + (and (fboundp 'auth-source-search) + (string-match "\\`\\(.+\\)@\\([^@]+\\)\\'" key) + (let* ((user (match-string 1 key)) + (host (match-string 2 key)) + (secret + (plist-get + (car (or (auth-source-search :max 1 :host host :user user) + (auth-source-search :max 1 :host key))) + :secret))) + (if (functionp secret) + (funcall secret) + secret)))) + +(defun magit-process-git-credential-manager-core (process string) + "Authenticate using `git-credential-manager-core'. + +To use this function add it to the appropriate hook + (add-hook \\='magit-process-prompt-functions + \\='magit-process-git-credential-manager-core)" + (and (string-match "^option (enter for default): $" string) + (progn + (magit-process-buffer) + (let ((option (format "%c\n" + (read-char-choice "Option: " '(?\r ?\j ?1 ?2))))) + (insert-before-markers-and-inherit option) + (process-send-string process option))))) + +(defun magit-process-password-prompt (process string) + "Find a password based on prompt STRING and send it to git. +Use `magit-process-password-prompt-regexps' to find a known +prompt. If and only if one is found, then call functions in +`magit-process-find-password-functions' until one of them returns +the password. If all functions return nil, then read the password +from the user." + (when-let ((prompt (magit-process-match-prompt + magit-process-password-prompt-regexps string))) + (process-send-string + process + (concat (or (and-let* ((key (match-string 99 string))) + (run-hook-with-args-until-success + 'magit-process-find-password-functions key)) + (let ((read-passwd-map + (magit-process-make-keymap process read-passwd-map))) + (read-passwd prompt))) + "\n")))) + +(defun magit-process-username-prompt (process string) + "Forward username prompts to the user." + (when-let ((prompt (magit-process-match-prompt + magit-process-username-prompt-regexps string))) + (process-send-string + process + (let ((minibuffer-local-map + (magit-process-make-keymap process minibuffer-local-map))) + (concat (read-string prompt nil nil (user-login-name)) "\n"))))) + +(defun magit-process-match-prompt (prompts string) + "Match STRING against PROMPTS and set match data. +Return the matched string, appending \": \" if needed." + (when (seq-some (##string-match % string) prompts) + (let ((prompt (match-string 0 string))) + (cond ((string-suffix-p ": " prompt) prompt) + ((string-suffix-p ":" prompt) (concat prompt " ")) + (t (concat prompt ": ")))))) + +(defun magit--process-coding-system () + (let ((fro (or magit-git-output-coding-system + (car default-process-coding-system))) + (to (cdr default-process-coding-system))) + (if magit-process-ensure-unix-line-ending + (cons (coding-system-change-eol-conversion fro 'unix) + (coding-system-change-eol-conversion to 'unix)) + (cons fro to)))) + +(defvar magit-credential-hook nil + "Hook run before Git needs credentials.") + +(defvar magit-credential-cache-daemon-process nil) + +(defun magit-maybe-start-credential-cache-daemon () + "Maybe start a `git-credential-cache--daemon' process. + +If such a process is already running or if the value of option +`magit-credential-cache-daemon-socket' is nil, then do nothing. +Otherwise start the process passing the value of that options +as argument." + (unless (or (not magit-credential-cache-daemon-socket) + (process-live-p magit-credential-cache-daemon-process) + (memq magit-credential-cache-daemon-process + (list-system-processes))) + (setq magit-credential-cache-daemon-process + (or (seq-find (lambda (process) + (let* ((attr (process-attributes process)) + (comm (cdr (assq 'comm attr))) + (user (cdr (assq 'user attr)))) + (and (string= comm "git-credential-cache--daemon") + (string= user user-login-name)))) + (list-system-processes)) + (condition-case nil + (start-process "git-credential-cache--daemon" + " *git-credential-cache--daemon*" + (magit-git-executable) + "credential-cache--daemon" + magit-credential-cache-daemon-socket) + ;; Some Git implementations (e.g., Windows) won't have + ;; this program; if we fail the first time, stop trying. + ((debug error) + (remove-hook 'magit-credential-hook + #'magit-maybe-start-credential-cache-daemon))))))) + +(add-hook 'magit-credential-hook #'magit-maybe-start-credential-cache-daemon) + +(defvar-keymap magit-mode-line-process-map + :doc "Keymap for `mode-line-process'." + " " 'magit-process-buffer) + +(defun magit-process-set-mode-line (program args) + "Display the git command (sans arguments) in the mode line." + (when (equal program (magit-git-executable)) + (setq args (nthcdr (length magit-git-global-arguments) args))) + (let ((str (concat " " (propertize + (concat (file-name-nondirectory program) + (and args (concat " " (car args)))) + 'mouse-face 'highlight + 'keymap magit-mode-line-process-map + 'help-echo "mouse-1: Show process buffer" + 'font-lock-face 'magit-mode-line-process)))) + (magit-repository-local-set 'mode-line-process str) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf + (setq mode-line-process str))) + (force-mode-line-update t))) + +(defun magit-process-set-mode-line-error-status (&optional error str) + "Apply an error face to the string set by `magit-process-set-mode-line'. + +If ERROR is supplied, include it in the `mode-line-process' tooltip. + +If STR is supplied, it replaces the `mode-line-process' text." + (setq str (or str (magit-repository-local-get 'mode-line-process))) + (when str + (setq error (format "%smouse-1: Show process buffer" + (if (stringp error) + (concat error "\n\n") + ""))) + (setq str (concat " " (propertize + (substring-no-properties str 1) + 'mouse-face 'highlight + 'keymap magit-mode-line-process-map + 'help-echo error + 'font-lock-face 'magit-mode-line-process-error))) + (magit-repository-local-set 'mode-line-process str) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf + (setq mode-line-process str))) + (force-mode-line-update t) + ;; We remove any error status from the mode line when a magit + ;; buffer is refreshed (see `magit-refresh-buffer'), but we must + ;; ensure that we ignore any refreshes during the remainder of the + ;; current command -- otherwise a newly-set error status would be + ;; removed before it was seen. We set a flag which prevents the + ;; status from being removed prior to the next command, so that + ;; the error status is guaranteed to remain visible until then. + (let ((repokey (magit-repository-local-repository))) + ;; The following closure captures the repokey value, and is + ;; added to `pre-command-hook'. + (cl-labels ((enable-magit-process-unset-mode-line () + ;; Remove ourself from the hook variable, so + ;; that we only run once. + (remove-hook 'pre-command-hook + #'enable-magit-process-unset-mode-line) + ;; Clear the inhibit flag for the repository in + ;; which we set it. + (magit-repository-local-set + 'inhibit-magit-process-unset-mode-line nil repokey))) + ;; Set the inhibit flag until the next command is invoked. + (magit-repository-local-set + 'inhibit-magit-process-unset-mode-line t repokey) + (add-hook 'pre-command-hook + #'enable-magit-process-unset-mode-line))))) + +(defun magit-process-unset-mode-line-error-status () + "Remove any current error status from the mode line." + (let ((status (or mode-line-process + (magit-repository-local-get 'mode-line-process)))) + (when (and status + (eq (get-text-property 1 'font-lock-face status) + 'magit-mode-line-process-error)) + (magit-process-unset-mode-line)))) + +(add-hook 'magit-refresh-buffer-hook + #'magit-process-unset-mode-line-error-status) + +(defun magit-process-unset-mode-line (&optional directory) + "Remove the git command from the mode line." + (let ((default-directory (or directory default-directory))) + (unless (magit-repository-local-get 'inhibit-magit-process-unset-mode-line) + (magit-repository-local-set 'mode-line-process nil) + (dolist (buf (magit-mode-get-buffers)) + (with-current-buffer buf (setq mode-line-process nil))) + (force-mode-line-update t)))) + +(defvar magit-process-error-message-regexps + (list "^\\*ERROR\\*: Canceled by user$" + "^\\(?:error\\|fatal\\|git\\): \\(.*\\)$" + "^\\(Cannot rebase:.*\\)$")) + +(define-error 'magit-git-error "Git error") + +(defun magit-process-error-summary (process-buf section) + "A one-line error summary from the given SECTION." + (and (buffer-live-p process-buf) + (with-current-buffer process-buf + (and (oref section content) + (save-excursion + (goto-char (oref section end)) + (run-hook-wrapped + 'magit-process-error-message-regexps + (lambda (re) + (save-excursion + (and (re-search-backward re (oref section start) t) + (match-string-no-properties 1)))))))))) + +(defun magit-process-error-tooltip (process-buf section) + "Returns the text from SECTION of the PROCESS-BUF buffer. + +Limited by `magit-process-error-tooltip-max-lines'." + (and (integerp magit-process-error-tooltip-max-lines) + (> magit-process-error-tooltip-max-lines 0) + (buffer-live-p process-buf) + (with-current-buffer process-buf + (save-excursion + (goto-char (or (oref section content) + (oref section start))) + (buffer-substring-no-properties + (point) + (save-excursion + (forward-line magit-process-error-tooltip-max-lines) + (goto-char + (if (> (point) (oref section end)) + (oref section end) + (point))) + ;; Remove any trailing whitespace. + (when (re-search-backward "[^[:space:]\n]" + (oref section start) t) + (forward-char 1)) + (point))))))) + +(defvar-local magit-this-error nil) + +(defun magit-process-finish (arg &optional process-buf _command-buf + default-dir section) + (unless (integerp arg) + (setq process-buf (process-buffer arg)) + (setq default-dir (process-get arg 'default-dir)) + (setq section (process-get arg 'section)) + (setq arg (process-exit-status arg))) + (when (fboundp 'dired-uncache) + (dired-uncache default-dir)) + (when (buffer-live-p process-buf) + (with-current-buffer process-buf + (magit-process-finish-section section arg))) + (if (= arg 0) + (magit-process-unset-mode-line default-dir) + (let ((msg (magit-process-error-summary process-buf section))) + (if magit-process-display-mode-line-error + (magit-process-set-mode-line-error-status + (or (magit-process-error-tooltip process-buf section) msg)) + (magit-process-unset-mode-line default-dir)) + (when (buffer-live-p process-buf) + (with-current-buffer process-buf + (when-let ((status-buf (magit-get-mode-buffer 'magit-status-mode))) + (with-current-buffer status-buf + (setq magit-this-error msg))))) + (let ((usage + (and magit-show-process-buffer-hint + (if-let ((keys (where-is-internal 'magit-process-buffer))) + (format "Type %s to see %S for details" + (key-description (car keys)) process-buf) + (format "See %S for details" process-buf))))) + (if magit-process-raise-error + (signal 'magit-git-error + (list msg (or usage (list 'in default-dir)))) + (message "Git error: %s" + (concat msg (and usage (format " [%s]" usage)))))))) + arg) + +(defun magit-process-finish-section (section exit-code) + (let ((inhibit-read-only t) + (buffer (current-buffer)) + (marker (oref section start))) + (goto-char marker) + (save-excursion + (delete-char 3) + (set-marker-insertion-type marker nil) + (insert (propertize (format "%3s" exit-code) + 'magit-section section + 'font-lock-face (if (= exit-code 0) + 'magit-process-ok + 'magit-process-ng))) + (set-marker-insertion-type marker t)) + (when (eq magit-process-apply-ansi-colors t) + (ansi-color-apply-on-region (oref section content) + (oref section end))) + (if (= (oref section end) + (+ (line-end-position) 2)) + (save-excursion + (goto-char (1+ (line-end-position))) + (delete-char -1) + (oset section content nil)) + (when (and (= exit-code 0) + (not (seq-some (##eq (window-buffer %) buffer) + (window-list)))) + (magit-section-hide section))))) + +(defun magit-process-display-buffer (process) + (when (process-live-p process) + (let ((buf (process-buffer process))) + (cond ((not (buffer-live-p buf))) + ((= magit-process-popup-time 0) + (if (minibufferp) + (switch-to-buffer-other-window buf) + (pop-to-buffer buf))) + ((> magit-process-popup-time 0) + (run-with-timer magit-process-popup-time nil + (lambda (p) + (when (eq (process-status p) 'run) + (let ((buf (process-buffer p))) + (when (buffer-live-p buf) + (if (minibufferp) + (switch-to-buffer-other-window buf) + (pop-to-buffer buf)))))) + process)))))) + +(defun magit--log-action (summary line list) + (let (heading lines) + (if (cdr list) + (progn (setq heading (funcall summary list)) + (setq lines (mapcar line list))) + (setq heading (funcall line (car list)))) + (with-current-buffer (magit-process-buffer t) + (goto-char (1- (point-max))) + (let ((inhibit-read-only t)) + (magit-insert-section (message) + (magit-insert-heading (concat " * " heading)) + (when lines + (dolist (line lines) + (insert line "\n")) + (insert "\n")))) + (let ((inhibit-message t)) + (when heading + (setq lines (cons heading lines))) + (message (string-join lines "\n")))))) + +;;; _ +(provide 'magit-process) +;;; magit-process.el ends here blob - /dev/null blob + 7116c29d3e791dfca3559c265ca82390da05bcd0 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-pull.el @@ -0,0 +1,166 @@ +;;; magit-pull.el --- Update local objects and refs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements pull commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-pull-or-fetch nil + "Whether `magit-pull' also offers some fetch suffixes." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +;;; Commands + +;;;###autoload (autoload 'magit-pull "magit-pull" nil t) +(transient-define-prefix magit-pull () + "Pull from another repository." + :man-page "git-pull" + :incompatible '(("--ff-only" "--rebase")) + [:description + (lambda () (if magit-pull-or-fetch "Pull arguments" "Arguments")) + ("-f" "Fast-forward only" "--ff-only") + ("-r" "Rebase local commits" ("-r" "--rebase")) + ("-A" "Autostash" "--autostash" :level 7) + ("-F" "Force" ("-f" "--force"))] + [:description + (lambda () + (if-let ((branch (magit-get-current-branch))) + (concat + (propertize "Pull into " 'face 'transient-heading) + (propertize branch 'face 'magit-branch-local) + (propertize " from" 'face 'transient-heading)) + (propertize "Pull from" 'face 'transient-heading))) + ("p" magit-pull-from-pushremote) + ("u" magit-pull-from-upstream) + ("e" "elsewhere" magit-pull-branch)] + ["Fetch from" + :if-non-nil magit-pull-or-fetch + ("f" "remotes" magit-fetch-all-no-prune) + ("F" "remotes and prune" magit-fetch-all-prune)] + ["Fetch" + :if-non-nil magit-pull-or-fetch + ("o" "another branch" magit-fetch-branch) + ("s" "explicit refspec" magit-fetch-refspec) + ("m" "submodules" magit-fetch-modules)] + ["Configure" + ("r" magit-branch..rebase :if magit-get-current-branch) + ("C" "variables..." magit-branch-configure)] + (interactive) + (transient-setup 'magit-pull nil nil :scope (magit-get-current-branch))) + +(defun magit-pull-arguments () + (transient-args 'magit-pull)) + +;;;###autoload (autoload 'magit-pull-from-pushremote "magit-pull" nil t) +(transient-define-suffix magit-pull-from-pushremote (args) + "Pull from the push-remote of the current branch. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :if #'magit-get-current-branch + :description #'magit-pull--pushbranch-description + (interactive (list (magit-pull-arguments))) + (pcase-let ((`(,branch ,remote) + (magit--select-push-remote "pull from there"))) + (run-hooks 'magit-credential-hook) + (magit-run-git-with-editor "pull" args remote branch))) + +(defun magit-pull--pushbranch-description () + ;; Also used by `magit-rebase-onto-pushremote'. + (let* ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch t)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + (target) + ((member remote (magit-list-remotes)) + (format "%s, replacing non-existent" v)) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-pull-from-upstream "magit-pull" nil t) +(transient-define-suffix magit-pull-from-upstream (args) + "Pull from the upstream of the current branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if #'magit-get-current-branch + :description #'magit-pull--upstream-description + (interactive (list (magit-pull-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (when (or current-prefix-arg + (not (or (magit-get-upstream-branch branch) + (magit--unnamed-upstream-p remote merge)))) + (magit-set-upstream-branch + branch (magit-read-upstream-branch + branch (format "Set upstream of %s and pull from there" branch))) + (setq remote (magit-get "branch" branch "remote")) + (setq merge (magit-get "branch" branch "merge"))) + (run-hooks 'magit-credential-hook) + (magit-run-git-with-editor "pull" args remote merge))) + +(defun magit-pull--upstream-description () + (and-let* ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (format "%s of %s" + (magit--propertize-face merge 'magit-branch-remote) + (magit--propertize-face remote 'bold))) + ((magit--valid-upstream-p remote merge) + (concat u ", replacing non-existent")) + ((or remote merge) + (concat u ", replacing invalid")) + (t + (concat u ", setting that"))))))) + +;;;###autoload +(defun magit-pull-branch (source args) + "Pull from a branch read in the minibuffer." + (interactive (list (magit-read-remote-branch "Pull" nil nil nil t) + (magit-pull-arguments))) + (run-hooks 'magit-credential-hook) + (pcase-let ((`(,remote . ,branch) + (magit-get-tracked source))) + (magit-run-git-with-editor "pull" args remote branch))) + +;;; _ +(provide 'magit-pull) +;;; magit-pull.el ends here blob - /dev/null blob + 1b8acb4265b642e3e7f33836e7166315626f5f89 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-push.el @@ -0,0 +1,373 @@ +;;; magit-push.el --- Update remote objects and refs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements push commands. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-push "magit-push" nil t) +(transient-define-prefix magit-push () + "Push to another repository." + :man-page "git-push" + ["Arguments" + ("-f" "Force with lease" (nil "--force-with-lease")) + ("-F" "Force" ("-f" "--force")) + ("-h" "Disable hooks" "--no-verify") + ("-n" "Dry run" ("-n" "--dry-run")) + ("-u" "Set upstream" "--set-upstream" :level 5) + ("-T" "Include all tags" "--tags") + ("-t" "Include related annotated tags" "--follow-tags")] + [:if magit-get-current-branch + :description (##format (propertize "Push %s to" 'face 'transient-heading) + (propertize (magit-get-current-branch) + 'face 'magit-branch-local)) + ("p" magit-push-current-to-pushremote) + ("u" magit-push-current-to-upstream) + ("e" "elsewhere" magit-push-current)] + ["Push" + [("o" "another branch" magit-push-other) + ("r" "explicit refspecs" magit-push-refspecs) + ("m" "matching branches" magit-push-matching)] + [("T" "a tag" magit-push-tag) + ("t" "all tags" magit-push-tags) + (6 "n" "a note ref" magit-push-notes-ref)]] + ["Configure" + ("C" "Set variables..." magit-branch-configure)]) + +(defun magit-push-arguments () + (transient-args 'magit-push)) + +(defun magit-git-push (branch target args) + (run-hooks 'magit-credential-hook) + ;; If the remote branch already exists, then we do not have to + ;; qualify the target, which we prefer to avoid doing because + ;; using the default namespace is wrong in obscure cases. + (pcase-let ((namespace (if (magit-get-tracked target) "" "refs/heads/")) + (`(,remote . ,target) + (magit-split-branch-name target))) + (magit-run-git-async "push" "-v" args remote + (format "%s:%s%s" branch namespace target)))) + +;;;###autoload (autoload 'magit-push-current-to-pushremote "magit-push" nil t) +(transient-define-suffix magit-push-current-to-pushremote (args) + "Push the current branch to its push-remote. + +When the push-remote is not configured, then read the push-remote +from the user, set it, and then push to it. With a prefix +argument the push-remote can be changed before pushed to it." + :if #'magit-get-current-branch + :description #'magit-push--pushbranch-description + (interactive (list (magit-push-arguments))) + (pcase-let ((`(,branch ,remote ,changed) + (magit--select-push-remote "push there"))) + (when changed + (magit-confirm 'set-and-push + (list "Really use \"%s\" as push-remote and push \"%s\" there" + remote branch))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote + (format "refs/heads/%s:refs/heads/%s" + branch branch)))) ; see #3847 and #3872 + +(defun magit-push--pushbranch-description () + (let* ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch t)) + (remote (magit-get-push-remote branch)) + (v (magit--push-remote-variable branch t))) + (cond + (target) + ((member remote (magit-list-remotes)) + (format "%s, creating it" + (magit--propertize-face (concat remote "/" branch) + 'magit-branch-remote))) + (remote + (format "%s, replacing invalid" v)) + (t + (format "%s, setting that" v))))) + +;;;###autoload (autoload 'magit-push-current-to-upstream "magit-push" nil t) +(transient-define-suffix magit-push-current-to-upstream (args) + "Push the current branch to its upstream branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if #'magit-get-current-branch + :description #'magit-push--upstream-description + (interactive (list (magit-push-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge"))) + (when (or current-prefix-arg + (not (or (magit-get-upstream-branch branch) + (magit--unnamed-upstream-p remote merge) + (magit--valid-upstream-p remote merge)))) + (let* ((branches (cl-union (mapcar (##concat % "/" branch) + (magit-list-remotes)) + (magit-list-remote-branch-names) + :test #'equal)) + (upstream (magit-completing-read + (format "Set upstream of %s and push there" branch) + branches nil nil nil 'magit-revision-history + (or (car (member (magit-remote-branch-at-point) branches)) + (car (member "origin/master" branches))))) + (upstream* (or (magit-get-tracked upstream) + (magit-split-branch-name upstream)))) + (setq remote (car upstream*)) + (setq merge (cdr upstream*)) + (unless (string-prefix-p "refs/" merge) + ;; User selected a non-existent remote-tracking branch. + ;; It is very likely, but not certain, that this is the + ;; correct thing to do. It is even more likely that it + ;; is what the user wants to happen. + (setq merge (concat "refs/heads/" merge))) + (magit-confirm 'set-and-push + (list "Really use \"%s\" as upstream and push \"%s\" there" + upstream branch))) + (cl-pushnew "--set-upstream" args :test #'equal)) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote (concat branch ":" merge)))) + +(defun magit-push--upstream-description () + (and-let* ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (format "%s as %s" + (magit--propertize-face remote 'bold) + (magit--propertize-face merge 'magit-branch-remote))) + ((magit--valid-upstream-p remote merge) + (format "%s creating %s" + (magit--propertize-face remote 'magit-branch-remote) + (magit--propertize-face merge 'magit-branch-remote))) + ((or remote merge) + (concat u ", creating it and replacing invalid")) + (t + (concat u ", creating it"))))))) + +;;;###autoload +(defun magit-push-current (target args) + "Push the current branch to a branch read in the minibuffer." + (interactive + (if-let ((current (magit-get-current-branch))) + (list (magit-read-remote-branch (format "Push %s to" current) + nil nil current 'confirm) + (magit-push-arguments)) + (user-error "No branch is checked out"))) + (magit-git-push (magit-get-current-branch) target args)) + +;;;###autoload +(defun magit-push-other (source target args) + "Push an arbitrary branch or commit somewhere. +Both the source and the target are read in the minibuffer." + (interactive + (let ((source (magit-read-local-branch-or-commit "Push"))) + (list source + (magit-read-remote-branch + (format "Push %s to" source) nil + (if (magit-local-branch-p source) + (or (magit-get-push-branch source) + (magit-get-upstream-branch source)) + (and (magit-rev-ancestor-p source "HEAD") + (or (magit-get-push-branch) + (magit-get-upstream-branch)))) + source 'confirm) + (magit-push-arguments)))) + (magit-git-push source target args)) + +(defvar magit-push-refspecs-history nil) + +;;;###autoload +(defun magit-push-refspecs (remote refspecs args) + "Push one or multiple REFSPECS to a REMOTE. +Both the REMOTE and the REFSPECS are read in the minibuffer. To +use multiple REFSPECS, separate them with commas. Completion is +only available for the part before the colon, or when no colon +is used." + (interactive + (list (magit-read-remote "Push to remote") + (magit-completing-read-multiple + "Push refspec,s: " + (cons "HEAD" (magit-list-local-branch-names)) + nil nil nil 'magit-push-refspecs-history) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote refspecs)) + +;;;###autoload +(defun magit-push-matching (remote &optional args) + "Push all matching branches to another repository. +If multiple remotes exist, then read one from the user. +If just one exists, use that without requiring confirmation." + (interactive (list (magit-read-remote "Push matching branches to" nil t) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote ":")) + +;;;###autoload +(defun magit-push-tags (remote &optional args) + "Push all tags to another repository. +If only one remote exists, then push to that. Otherwise prompt +for a remote, offering the remote configured for the current +branch as default." + (interactive (list (magit-read-remote "Push tags to remote" nil t) + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote "--tags" args)) + +;;;###autoload +(defun magit-push-tag (tag remote &optional args) + "Push a tag to another repository." + (interactive + (let ((tag (magit-read-tag "Push tag"))) + (list tag (magit-read-remote (format "Push %s to remote" tag) nil t) + (magit-push-arguments)))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote tag args)) + +;;;###autoload +(defun magit-push-notes-ref (ref remote &optional args) + "Push a notes ref to another repository." + (interactive + (let ((note (magit-notes-read-ref "Push notes" nil nil))) + (list note + (magit-read-remote (format "Push %s to remote" note) nil t) + (magit-push-arguments)))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" remote ref args)) + +;;;###autoload (autoload 'magit-push-implicitly "magit-push" nil t) +(transient-define-suffix magit-push-implicitly (args) + "Push somewhere without using an explicit refspec. + +This command simply runs \"git push -v [ARGS]\". ARGS are the +arguments specified in the popup buffer. No explicit refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'. + +If you add this suffix to a transient prefix without explicitly +specifying the description, then an attempt is made to predict +what this command will do. To add it use something like: + + (transient-insert-suffix \\='magit-push \"o\" + \\='(\"i\" magit-push-implicitly))" + :description #'magit-push-implicitly--desc + (interactive (list (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args)) + +(defun magit-push-implicitly--desc () + ;; This implements the logic for git push as documented. + ;; First, we resolve a remote to use based on various remote and + ;; pushRemote options. + ;; Then, we resolve the refspec to use for the remote based on push + ;; and pushDefault options. + ;; Note that the remote and refspec to push are handled separately, + ;; so it doesn't make sense to talk about "pushing to upstream". + ;; Depending on the options, you could end up pushing to the + ;; "upstream" remote but not the "upstream" branch, and vice versa. + (let* ((branch (magit-get-current-branch)) + (remote (or (magit-get-push-remote branch) + ;; Note: Avoid `magit-get-remote' because it + ;; filters out the local repo case ("."). + (magit-get "branch" branch "remote") + (let ((remotes (magit-list-remotes))) + (cond + ((and (magit-git-version>= "2.27") + (length= remotes 1)) + (car remotes)) + ((member "origin" remotes) "origin")))))) + (if (null remote) + "nothing (no remote)" + (let ((refspec (magit-get "remote" remote "push"))) + (if refspec + (format "to %s with refspecs %s" + (magit--propertize-face remote 'bold) + (magit--propertize-face refspec 'bold)) + (pcase (or (magit-get "push.default") "simple") + ("nothing" "nothing (due to push.default)") + ((or "current" "simple") + (format "%s to %s" + (magit--propertize-face branch 'magit-branch-current) + (magit--propertize-face (format "%s/%s" remote branch) + 'magit-branch-remote))) + ((or "upstream" "tracking") + (let ((ref (magit-get "branch" branch "merge"))) + (if ref + (format "%s to %s" + (magit--propertize-face branch 'magit-branch-current) + (cond + ((string-prefix-p "refs/heads/" ref) + (magit--propertize-face + (format "%s/%s" remote + (substring ref (length "refs/heads/"))) + 'magit-branch-remote)) + ((not (string-match "/" ref)) + (magit--propertize-face (format "%s/%s" remote ref) + 'magit-branch-remote)) + ((format "%s as %s" + (magit--propertize-face remote 'bold) + (magit--propertize-face ref 'bold))))) + "nothing (no upstream)"))) + ("matching" (format "all matching to %s" + (magit--propertize-face remote 'bold))))))))) + +;;;###autoload (autoload 'magit-push-to-remote "magit-push" nil t) +(transient-define-suffix magit-push-to-remote (remote args) + "Push to REMOTE without using an explicit refspec. +The REMOTE is read in the minibuffer. + +This command simply runs \"git push -v [ARGS] REMOTE\". ARGS +are the arguments specified in the popup buffer. No refspec +arguments are used. Instead the behavior depends on at least +these Git variables: `push.default', `remote.pushDefault', +`branch..pushRemote', `branch..remote', +`branch..merge', and `remote..push'. + +You can add this command as a suffix using something like: + + (transient-insert-suffix \\='magit-push \"o\" + \\='(\"x\" magit-push-to-remote))" + :description #'magit-push-to-remote--desc + (interactive (list (magit-read-remote "Push to remote") + (magit-push-arguments))) + (run-hooks 'magit-credential-hook) + (magit-run-git-async "push" "-v" args remote)) + +(defun magit-push-to-remote--desc () + (format "using %s" (magit--propertize-face "git push " 'bold))) + +;;; _ +(provide 'magit-push) +;;; magit-push.el ends here blob - /dev/null blob + 7ffce3e0fc9adcd8a5d4fb6be1555b538fea9e9b (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-reflog.el @@ -0,0 +1,208 @@ +;;; magit-reflog.el --- Inspect ref history -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for looking at Git reflogs. + +;;; Code: + +(require 'magit-core) +(require 'magit-log) + +;;; Options + +(defcustom magit-reflog-limit 256 + "Maximal number of entries initially shown in reflog buffers. +The limit in the current buffer can be changed using \"+\" +and \"-\"." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'number) + +(defcustom magit-reflog-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-reflog-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-log + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-reflog-mode)) + +;;; Faces + +(defface magit-reflog-commit '((t :foreground "green")) + "Face for commit commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-amend '((t :foreground "magenta")) + "Face for amend commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-merge '((t :foreground "green")) + "Face for merge, checkout and branch commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-checkout '((t :foreground "blue")) + "Face for checkout commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-reset '((t :foreground "red")) + "Face for reset commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-rebase '((t :foreground "magenta")) + "Face for rebase commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-cherry-pick '((t :foreground "green")) + "Face for cherry-pick commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-remote '((t :foreground "cyan")) + "Face for pull and clone commands in reflogs." + :group 'magit-faces) + +(defface magit-reflog-other '((t :foreground "cyan")) + "Face for other commands in reflogs." + :group 'magit-faces) + +;;; Commands + +;;;###autoload +(defun magit-reflog-current () + "Display the reflog of the current branch. +If `HEAD' is detached, then show the reflog for that instead." + (interactive) + (magit-reflog-setup-buffer (or (magit-get-current-branch) "HEAD"))) + +;;;###autoload +(defun magit-reflog-other (ref) + "Display the reflog of a branch or another ref." + (interactive (list (magit-read-local-branch-or-ref "Show reflog for"))) + (magit-reflog-setup-buffer ref)) + +;;;###autoload +(defun magit-reflog-head () + "Display the `HEAD' reflog." + (interactive) + (magit-reflog-setup-buffer "HEAD")) + +;;; Mode + +(defvar-keymap magit-reflog-mode-map + :doc "Keymap for `magit-reflog-mode'." + :parent magit-log-mode-map + "C-c C-n" #'undefined + "L" #'magit-margin-settings) + +(define-derived-mode magit-reflog-mode magit-mode "Magit Reflog" + "Mode for looking at Git reflog. + +This mode is documented in info node `(magit)Reflog'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit at point. + +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-reflog-mode-map}" + :interactive nil + :group 'magit-log + (magit-hack-dir-local-variables) + (setq magit--imenu-item-types 'commit)) + +(defun magit-reflog-setup-buffer (ref) + (require 'magit) + (magit-setup-buffer #'magit-reflog-mode nil + (magit-buffer-refname ref) + (magit-buffer-log-args (list (format "-n%s" magit-reflog-limit))))) + +(defun magit-reflog-refresh-buffer () + (magit-set-header-line-format (concat "Reflog for " magit-buffer-refname)) + (magit-insert-section (reflogbuf) + (magit-git-wash (apply-partially #'magit-log-wash-log 'reflog) + "reflog" "show" "--format=%h%x00%aN%x00%gd%x00%gs" "--date=raw" + magit-buffer-log-args magit-buffer-refname "--"))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-reflog-mode)) + magit-buffer-refname) + +(defvar magit-reflog-labels + '(("commit" . magit-reflog-commit) + ("amend" . magit-reflog-amend) + ("merge" . magit-reflog-merge) + ("checkout" . magit-reflog-checkout) + ("branch" . magit-reflog-checkout) + ("reset" . magit-reflog-reset) + ("rebase" . magit-reflog-rebase) + ("rewritten" . magit-reflog-rebase) + ("cherry-pick" . magit-reflog-cherry-pick) + ("initial" . magit-reflog-commit) + ("pull" . magit-reflog-remote) + ("clone" . magit-reflog-remote) + ("autosave" . magit-reflog-commit) + ("restart" . magit-reflog-reset))) + +(defun magit-reflog-format-subject (subject) + (let* ((match (string-match magit-reflog-subject-re subject)) + (command (and match (match-string 1 subject))) + (option (and match (match-string 2 subject))) + (type (and match (match-string 3 subject))) + (label (if (string= command "commit") + (or type command) + command)) + (text (if (string= command "commit") + label + (string-join (delq nil (list command option type)) " ")))) + (format "%-16s " + (magit--propertize-face + text (or (cdr (assoc label magit-reflog-labels)) + 'magit-reflog-other))))) + +;;; _ +(provide 'magit-reflog) +;;; magit-reflog.el ends here blob - /dev/null blob + 2bcee3e7e2414d192bb0230602a73d91996b6901 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-refs.el @@ -0,0 +1,814 @@ +;;; magit-refs.el --- Listing references -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for listing references in a buffer. + +;;; Code: + +(require 'magit) + +;;; Options + +(defgroup magit-refs nil + "Inspect and manipulate Git branches and tags." + :link '(info-link "(magit)References Buffer") + :group 'magit-modes) + +(defcustom magit-refs-mode-hook nil + "Hook run after entering Magit-Refs mode." + :package-version '(magit . "2.1.0") + :group 'magit-refs + :type 'hook) + +(defcustom magit-refs-sections-hook + (list #'magit-insert-error-header + #'magit-insert-branch-description + #'magit-insert-local-branches + #'magit-insert-remote-branches + #'magit-insert-tags) + "Hook run to insert sections into a references buffer." + :package-version '(magit . "2.1.0") + :group 'magit-refs + :type 'hook) + +(defcustom magit-refs-show-commit-count nil + "Whether to show commit counts in Magit-Refs mode buffers. + +all Show counts for branches and tags. +branch Show counts for branches only. +nil Never show counts. + +To change the value in an existing buffer use the command +`magit-refs-set-show-commit-count'." + :package-version '(magit . "2.1.0") + :group 'magit-refs + :safe (##memq % '(all branch nil)) + :type '(choice (const :tag "For branches and tags" all) + (const :tag "For branches only" branch) + (const :tag "Never" nil))) +(put 'magit-refs-show-commit-count 'safe-local-variable 'symbolp) +(put 'magit-refs-show-commit-count 'permanent-local t) + +(defcustom magit-refs-pad-commit-counts nil + "Whether to pad all counts on all sides in `magit-refs-mode' buffers. + +If this is nil, then some commit counts are displayed right next +to one of the branches that appear next to the count, without any +space in between. This might look bad if the branch name faces +look too similar to `magit-dimmed'. + +If this is non-nil, then spaces are placed on both sides of all +commit counts." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'boolean) + +(defvar magit-refs-show-push-remote nil + "Whether to show the push-remotes of local branches. +Also show the commits that the local branch is ahead and behind +the push-target. Unfortunately there is a bug in Git that makes +this useless (the commits ahead and behind the upstream are +shown), so this isn't enabled yet.") + +(defcustom magit-refs-show-remote-prefix nil + "Whether to show the remote prefix in lists of remote branches. + +This is redundant because the name of the remote is already shown +in the heading preceding the list of its branches." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'boolean) + +(defcustom magit-refs-show-branch-descriptions nil + "Whether to show the description, if any, of local branches. +To distinguish branch descriptions from the commit summary of the tip, +which is shown when there is no description or this option is disabled, +descriptions use the bold face." + :package-version '(magit . "4.3.0") + :group 'magit-refs + :type 'boolean) + +(defcustom magit-refs-margin + (list nil + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-refs-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-margin + :safe (##memq % '(all branch nil)) + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-refs-mode)) + +(defcustom magit-refs-margin-for-tags nil + "Whether to show information about tags in the margin. + +This is disabled by default because it is slow if there are many +tags." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-margin + :type 'boolean) + +(defcustom magit-refs-primary-column-width '(16 . 32) + "Width of the focus column in `magit-refs-mode' buffers. + +The primary column is the column that contains the name of the +branch that the current row is about. + +If this is an integer, then the column is that many columns wide. +Otherwise it has to be a cons-cell of two integers. The first +specifies the minimal width, the second the maximal width. In that +case the actual width is determined using the length of the names +of the shown local branches. (Remote branches and tags are not +taken into account when calculating to optimal width.)" + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type '(choice (integer :tag "Constant wide") + (cons :tag "Wide constrains" + (integer :tag "Minimum") + (integer :tag "Maximum")))) + +(defcustom magit-refs-focus-column-width 5 + "Width of the focus column in `magit-refs-mode' buffers. + +The focus column is the first column, which marks one +branch (usually the current branch) as the focused branch using +\"*\" or \"@\". For each other reference, this column optionally +shows how many commits it is ahead of the focused branch and \"<\", or +if it isn't ahead then the commits it is behind and \">\", or if it +isn't behind either, then a \"=\". + +This column may also display only \"*\" or \"@\" for the focused +branch, in which case this option is ignored. Use \"L v\" to +change the verbosity of this column." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type 'integer) + +(defcustom magit-refs-filter-alist nil + "Alist controlling which refs are omitted from `magit-refs-mode' buffers. + +The purpose of this option is to forgo displaying certain refs +based on their name. If you want to not display any refs of a +certain type, then you should remove the appropriate function +from `magit-refs-sections-hook' instead. + +All keys are tried in order until one matches. Then its value +is used and subsequent elements are ignored. If the value is +non-nil, then the reference is displayed, otherwise it is not. +If no element matches, then the reference is displayed. + +A key can either be a regular expression that the refname has to +match, or a function that takes the refname as only argument and +returns a boolean. A remote branch such as \"origin/master\" is +displayed as just \"master\", however for this comparison the +former is used." + :package-version '(magit . "2.12.0") + :group 'magit-refs + :type '(alist :key-type (choice :tag "Key" regexp function) + :value-type (boolean :tag "Value" + :on "show (non-nil)" + :off "omit (nil)"))) + +(defcustom magit-visit-ref-behavior nil + "Control how `magit-visit-ref' behaves in `magit-refs-mode' buffers. + +By default `magit-visit-ref' behaves like `magit-show-commit', +in all buffers, including `magit-refs-mode' buffers. When the +type of the section at point is `commit' then \"RET\" is bound to +`magit-show-commit', and when the type is either `branch' or +`tag' then it is bound to `magit-visit-ref'. + +\"RET\" is one of Magit's most essential keys and at least by +default it should behave consistently across all of Magit, +especially because users quickly learn that it does something +very harmless; it shows more information about the thing at point +in another buffer. + +However \"RET\" used to behave differently in `magit-refs-mode' +buffers, doing surprising things, some of which cannot really be +described as \"visit this thing\". If you have grown accustomed +to such inconsistent, but to you useful, behavior, then you can +restore that by adding one or more of the below symbols to the +value of this option. But keep in mind that by doing so you +don't only introduce inconsistencies, you also lose some +functionality and might have to resort to `M-x magit-show-commit' +to get it back. + +`magit-visit-ref' looks for these symbols in the order in which +they are described here. If the presence of a symbol applies to +the current situation, then the symbols that follow do not affect +the outcome. + +`focus-on-ref' + + With a prefix argument update the buffer to show commit counts + and lists of cherry commits relative to the reference at point + instead of relative to the current buffer or `HEAD'. + + Instead of adding this symbol, consider pressing \\`C-u y o RET'. + +`create-branch' + + If point is on a remote branch, then create a new local branch + with the same name, use the remote branch as its upstream, and + then check out the local branch. + + Instead of adding this symbol, consider pressing \"b c RET RET\", + like you would do in other buffers. + +`checkout-any' + + Check out the reference at point. If that reference is a tag + or a remote branch, then this results in a detached `HEAD'. + + Instead of adding this symbol, consider pressing \"b b RET\", + like you would do in other buffers. + +`checkout-branch' + + Check out the local branch at point. + + Instead of adding this symbol, consider pressing \"b b RET\", + like you would do in other buffers." + :package-version '(magit . "2.9.0") + :group 'magit-refs + :group 'magit-commands + :options '(focus-on-ref create-branch checkout-any checkout-branch) + :type '(list :convert-widget custom-hook-convert-widget)) + +;;; Mode + +(defvar-keymap magit-refs-mode-map + :doc "Keymap for `magit-refs-mode'." + :parent magit-mode-map + "C-y" #'magit-refs-set-show-commit-count + "L" #'magit-margin-settings) + +(define-derived-mode magit-refs-mode magit-mode "Magit Refs" + "Mode which lists and compares references. + +This mode is documented in info node `(magit)References Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] or \\[magit-diff-show-or-scroll-up] \ +to visit the commit or branch at point. + +Type \\[magit-branch] to see available branch commands. +Type \\[magit-merge] to merge the branch or commit at point. +Type \\[magit-cherry-pick] to apply the commit at point. +Type \\[magit-reset] to reset `HEAD' to the commit at point. + +\\{magit-refs-mode-map}" + :interactive nil + :group 'magit-refs + (magit-hack-dir-local-variables) + (setq magit--imenu-group-types '(local remote tags))) + +(defun magit-refs-setup-buffer (ref args) + (magit-setup-buffer #'magit-refs-mode nil + (magit-buffer-upstream ref) + (magit-buffer-arguments args))) + +(defun magit-refs-refresh-buffer () + (setq magit-set-buffer-margin-refresh (not (magit-buffer-margin-p))) + (unless (magit-rev-verify magit-buffer-upstream) + (setq magit-refs-show-commit-count nil)) + (magit-set-header-line-format + (format "%s %s" magit-buffer-upstream + (string-join magit-buffer-arguments " "))) + (magit-insert-section (branchbuf) + (magit-run-section-hook 'magit-refs-sections-hook)) + (add-hook 'kill-buffer-hook #'magit-preserve-section-visibility-cache)) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-refs-mode)) + (cons magit-buffer-upstream magit-buffer-arguments)) + +;;; Commands + +;;;###autoload (autoload 'magit-show-refs "magit-refs" nil t) +(transient-define-prefix magit-show-refs (&optional transient) + "List and compare references in a dedicated buffer." + :man-page "git-branch" + :value (##magit-show-refs-arguments magit-prefix-use-buffer-arguments) + ["Arguments" + (magit-for-each-ref:--contains) + ("-M" "Merged" "--merged=" magit-transient-read-revision) + ("-m" "Merged to HEAD" "--merged") + ("-N" "Not merged" "--no-merged=" magit-transient-read-revision) + ("-n" "Not merged to HEAD" "--no-merged") + (magit-for-each-ref:--sort)] + ["Actions" + ("y" "Show refs, comparing them with HEAD" magit-show-refs-head) + ("c" "Show refs, comparing them with current branch" magit-show-refs-current) + ("o" "Show refs, comparing them with other branch" magit-show-refs-other) + ("r" "Show refs, changing commit count display" + magit-refs-set-show-commit-count)] + (interactive (list (or (derived-mode-p 'magit-refs-mode) + current-prefix-arg))) + (if transient + (transient-setup 'magit-show-refs) + (magit-refs-setup-buffer "HEAD" (magit-show-refs-arguments)))) + +(defun magit-show-refs-arguments (&optional use-buffer-args) + (unless use-buffer-args + (setq use-buffer-args magit-direct-use-buffer-arguments)) + (let (args) + (cond + ((eq transient-current-command 'magit-show-refs) + (setq args (transient-args 'magit-show-refs))) + ((eq major-mode 'magit-refs-mode) + (setq args magit-buffer-arguments)) + ((and (memq use-buffer-args '(always selected)) + (and-let* ((buffer (magit-get-mode-buffer + 'magit-refs-mode nil + (eq use-buffer-args 'selected)))) + (progn + (setq args (buffer-local-value 'magit-buffer-arguments buffer)) + t)))) + (t + (setq args (alist-get 'magit-show-refs transient-values)))) + args)) + +(transient-define-argument magit-for-each-ref:--contains () + :description "Contains" + :class 'transient-option + :key "-c" + :argument "--contains=" + :reader #'magit-transient-read-revision) + +(transient-define-argument magit-for-each-ref:--sort () + :description "Sort" + :class 'transient-option + :key "-s" + :argument "--sort=" + :reader #'magit-read-ref-sort) + +(defun magit-read-ref-sort (prompt initial-input _history) + (magit-completing-read prompt + '("-committerdate" "-authordate" + "committerdate" "authordate") + nil nil initial-input)) + +;;;###autoload +(defun magit-show-refs-head (&optional args) + "List and compare references in a dedicated buffer. +Compared with `HEAD'." + (interactive (list (magit-show-refs-arguments))) + (magit-refs-setup-buffer "HEAD" args)) + +;;;###autoload +(defun magit-show-refs-current (&optional args) + "List and compare references in a dedicated buffer. +Compare with the current branch or `HEAD' if it is detached." + (interactive (list (magit-show-refs-arguments))) + (magit-refs-setup-buffer (magit-get-current-branch) args)) + +;;;###autoload +(defun magit-show-refs-other (&optional ref args) + "List and compare references in a dedicated buffer. +Compared with a branch read from the user." + (interactive (list (magit-read-other-branch "Compare with") + (magit-show-refs-arguments))) + (magit-refs-setup-buffer ref args)) + +(transient-define-suffix magit-refs-set-show-commit-count () + "Change for which refs the commit count is shown." + :description "Change verbosity" + :key "v" + :transient nil + :if-derived 'magit-refs-mode + (interactive) + (setq-local magit-refs-show-commit-count + (magit-read-char-case "Show commit counts for " nil + (?a "[a]ll refs" 'all) + (?b "[b]ranches only" t) + (?n "[n]othing" nil))) + (magit-refresh)) + +(defun magit-visit-ref () + "Visit the reference or revision at point in another buffer. +If there is no revision at point or with a prefix argument prompt +for a revision. + +This command behaves just like `magit-show-commit', except if +point is on a reference in a `magit-refs-mode' buffer (a buffer +listing branches and tags), in which case the behavior may be +different, but only if you have customized the option +`magit-visit-ref-behavior' (which see). When invoked from a +menu this command always behaves like `magit-show-commit'." + (interactive) + (if (and (derived-mode-p 'magit-refs-mode) + (magit-section-match '(branch tag)) + (not (magit-menu-position))) + (let ((ref (oref (magit-current-section) value))) + (cond (current-prefix-arg + (cond ((memq 'focus-on-ref magit-visit-ref-behavior) + (magit-refs-setup-buffer ref (magit-show-refs-arguments))) + (magit-visit-ref-behavior + ;; Don't prompt for commit to visit. + (let ((current-prefix-arg nil)) + (call-interactively #'magit-show-commit))))) + ((and (memq 'create-branch magit-visit-ref-behavior) + (magit-section-match [branch remote])) + (let ((branch (cdr (magit-split-branch-name ref)))) + (if (magit-branch-p branch) + (if (magit-rev-eq branch ref) + (magit-call-git "checkout" branch) + (setq branch (propertize branch 'face 'magit-branch-local)) + (setq ref (propertize ref 'face 'magit-branch-remote)) + (pcase (prog1 (read-char-choice (format (propertize "\ +Branch %s already exists. + [c]heckout %s as-is + [r]reset %s to %s and checkout %s + [a]bort " 'face 'minibuffer-prompt) branch branch branch ref branch) + '(?c ?r ?a)) + (message "")) ; otherwise prompt sticks + (?c (magit-call-git "checkout" branch)) + (?r (magit-call-git "checkout" "-B" branch ref)) + (?a (user-error "Abort")))) + (magit-call-git "checkout" "-b" branch ref)) + (setq magit-buffer-upstream branch) + (magit-refresh))) + ((or (memq 'checkout-any magit-visit-ref-behavior) + (and (memq 'checkout-branch magit-visit-ref-behavior) + (magit-section-match [branch local]))) + (magit-call-git "checkout" ref) + (setq magit-buffer-upstream ref) + (magit-refresh)) + (t + (call-interactively #'magit-show-commit)))) + (call-interactively #'magit-show-commit))) + +;;; Sections + +(defvar-keymap magit-remote-section-map + :doc "Keymap for `remote' sections." + " " #'magit-remote-rename + " " #'magit-remote-remove + "<2>" (magit-menu-item "Rename %s" #'magit-remote-rename) + "<1>" (magit-menu-item "Remove %m" #'magit-remote-remove)) + +(defvar-keymap magit-branch-section-map + :doc "Keymap for `branch' sections." + " " #'magit-branch-rename + " " #'magit-branch-delete + " " #'magit-visit-ref + "<3>" (magit-menu-item "Rename %s" #'magit-branch-rename) + "<2>" (magit-menu-item "Delete %m" #'magit-branch-delete) + "<1>" (magit-menu-item "Visit commit" #'magit-visit-ref)) + +(defvar-keymap magit-tag-section-map + :doc "Keymap for `tag' sections." + " " #'magit-tag-delete + " " #'magit-visit-ref + "<2>" (magit-menu-item "Delete %m" #'magit-tag-delete) + "<1>" (magit-menu-item "Visit %s" #'magit-visit-ref)) + +(defun magit--painted-branch-as-menu-section (section) + (and-let* ((branch (and (magit-section-match 'commit) + (magit--painted-branch-at-point)))) + (let ((dummy (magit-section :type 'branch :value branch))) + (oset dummy keymap magit-branch-section-map) + (dolist (slot '(start content hidden parent children)) + (when (slot-boundp section slot) + (setf (eieio-oref dummy slot) + (eieio-oref section slot)))) + dummy))) + +(add-hook 'magit-menu-alternative-section-hook + #'magit--painted-branch-as-menu-section) + +(defun magit-insert-branch-description () + "Insert header containing the description of the current branch. +Insert a header line with the name and description of the +current branch. The description is taken from the Git variable +`branch..description'; if that is undefined then no header +line is inserted at all." + (when-let* ((branch (magit-get-current-branch)) + (desc (magit-get "branch" branch "description")) + (desc (split-string desc "\n"))) + (when (equal (car (last desc)) "") + (setq desc (butlast desc))) + (magit-insert-section (branchdesc branch t) + (magit-insert-heading branch ": " (car desc)) + (when (cdr desc) + (insert (string-join (cdr desc) "\n")) + (insert "\n\n"))))) + +(defun magit-insert-tags () + "Insert sections showing all tags." + (when-let ((tags (magit-git-lines "tag" "--list" "-n" magit-buffer-arguments))) + (let ((_head (magit-rev-parse "HEAD"))) + (magit-insert-section (tags) + (magit-insert-heading (length tags) "Tags") + (dolist (tag tags) + (string-match "^\\([^ \t]+\\)[ \t]+\\([^ \t\n].*\\)?" tag) + (let ((tag (match-string 1 tag)) + (msg (match-string 2 tag))) + (when (magit-refs--insert-refname-p tag) + (magit-insert-section (tag tag t) + (magit-insert-heading + (magit-refs--format-focus-column tag 'tag) + (propertize tag 'font-lock-face 'magit-tag) + (make-string + (max 1 (- (if (consp magit-refs-primary-column-width) + (car magit-refs-primary-column-width) + magit-refs-primary-column-width) + (length tag))) + ?\s) + (and msg (magit-log--wash-summary msg))) + (when (and magit-refs-margin-for-tags (magit-buffer-margin-p)) + (magit-refs--format-margin tag)) + (magit-refs--insert-cherry-commits tag))))) + (insert ?\n) + (magit-make-margin-overlay))))) + +(defun magit-insert-remote-branches () + "Insert sections showing all remote-tracking branches." + (dolist (remote (magit-list-remotes)) + (magit-insert-section (remote remote) + (magit-insert-heading + (let ((pull (magit-get "remote" remote "url")) + (push (magit-get "remote" remote "pushurl"))) + (format (propertize "Remote %s (%s):" + 'font-lock-face 'magit-section-heading) + (propertize remote 'font-lock-face 'magit-branch-remote) + (concat pull (and pull push ", ") push)))) + (let (head) + (dolist (line (magit-git-lines "for-each-ref" "--format=\ +%(symref:short)%00%(refname:short)%00%(refname)%00%(subject)" + (concat "refs/remotes/" remote) + magit-buffer-arguments)) + (pcase-let ((`(,head-branch ,branch ,ref ,msg) + (cl-substitute nil "" + (split-string line "\0") + :test #'equal))) + (cond + (head-branch + ;; Note: Use `ref' instead of `branch' for the check + ;; below because 'refname:short' shortens the remote + ;; HEAD to '' instead of '/HEAD' as of + ;; Git v2.40.0. + (cl-assert + (equal ref (concat "refs/remotes/" remote "/HEAD"))) + (setq head head-branch)) + ((not (equal ref (concat "refs/remotes/" remote "/HEAD"))) + ;; ^ Skip mis-configured remotes where HEAD is not a + ;; symref. See #5092. + (when (magit-refs--insert-refname-p branch) + (magit-insert-section (branch branch t) + (let ((headp (equal branch head)) + (abbrev (if magit-refs-show-remote-prefix + branch + (substring branch (1+ (length remote)))))) + (magit-insert-heading + (magit-refs--format-focus-column branch) + (magit-refs--propertize-branch + abbrev ref (and headp 'magit-branch-remote-head)) + (make-string + (max 1 (- (if (consp magit-refs-primary-column-width) + (car magit-refs-primary-column-width) + magit-refs-primary-column-width) + (length abbrev))) + ?\s) + (and msg (magit-log--wash-summary msg)))) + (when (magit-buffer-margin-p) + (magit-refs--format-margin branch)) + (magit-refs--insert-cherry-commits branch)))))))) + (insert ?\n) + (magit-make-margin-overlay)))) + +(defun magit-insert-local-branches () + "Insert sections showing all local branches." + (magit-insert-section (local nil) + (magit-insert-heading t "Branches") + (dolist (line (magit-refs--format-local-branches)) + (pcase-let ((`(,branch . ,strings) line)) + (magit-insert-section + ((eval (if branch 'branch 'commit)) + (or branch (magit-rev-parse "HEAD")) + t) + (apply #'magit-insert-heading strings) + (when (magit-buffer-margin-p) + (magit-refs--format-margin branch)) + (magit-refs--insert-cherry-commits branch)))) + (insert ?\n) + (magit-make-margin-overlay))) + +(defun magit-insert-shelved-branches () + "Insert sections showing all shelved branches." + (when-let ((refs (magit-list-refs "refs/shelved/"))) + (magit-insert-section (shelved nil) + (magit-insert-heading t "Shelved branches") + (dolist (ref (nreverse refs)) + (magit-insert-section (shelved-branch ref t) + (magit-insert-heading + " " (magit--propertize-face (substring ref 13) 'magit-refname)) + (when (magit-buffer-margin-p) + (magit-refs--format-margin ref)) + (magit-refs--insert-cherry-commits ref))) + (insert ?\n) + (magit-make-margin-overlay)))) + +(defun magit-refs--format-local-branches () + (let ((lines (seq-keep #'magit-refs--format-local-branch + (magit-git-lines + "for-each-ref" + (concat "--format=\ +%(HEAD)%00%(refname:short)%00%(refname)%00\ +%(upstream:short)%00%(upstream)%00%(upstream:track)%00" + (if magit-refs-show-push-remote "\ +%(push:remotename)%00%(push)%00%(push:track)%00%(subject)" + "%00%00%00%(subject)")) + "refs/heads" + magit-buffer-arguments)))) + (unless (magit-get-current-branch) + (push (magit-refs--format-local-branch + (concat "*\0\0\0\0\0\0\0\0" (magit-rev-format "%s"))) + lines)) + (setq-local magit-refs-primary-column-width + (let ((def (default-value 'magit-refs-primary-column-width))) + (if (atom def) + def + (pcase-let ((`(,min . ,max) def)) + (min max (apply #'max min (mapcar #'car lines))))))) + (mapcar (pcase-lambda (`( ,_ ,branch ,focus + ,branch-desc ,u:ahead ,p:ahead + ,u:behind ,upstream ,p:behind ,msg)) + (list branch focus branch-desc u:ahead p:ahead + (make-string (max 1 (- magit-refs-primary-column-width + (length (concat branch-desc + u:ahead + p:ahead + u:behind)))) + ?\s) + u:behind upstream p:behind msg)) + lines))) + +(defun magit-refs--format-local-branch (line) + (pcase-let ((`(,head ,branch ,ref ,upstream ,u:ref ,u:track + ,push ,p:ref ,p:track ,msg) + (cl-substitute nil "" (split-string line "\0") :test #'equal))) + (when (or (not branch) + (magit-refs--insert-refname-p branch)) + (let* ((headp (equal head "*")) + (pushp (and push + magit-refs-show-push-remote + (magit-rev-verify p:ref) + (not (equal p:ref u:ref)))) + (branch-pretty + (if branch + (magit-refs--propertize-branch + branch ref (and headp 'magit-branch-current)) + (magit--propertize-face "(detached)" 'magit-branch-warning))) + (u:ahead (and u:track + (string-match "ahead \\([0-9]+\\)" u:track) + (magit--propertize-face + (concat (and magit-refs-pad-commit-counts " ") + (match-string 1 u:track) + ">") + 'magit-dimmed))) + (u:behind (and u:track + (string-match "behind \\([0-9]+\\)" u:track) + (magit--propertize-face + (concat "<" + (match-string 1 u:track) + (and magit-refs-pad-commit-counts " ")) + 'magit-dimmed))) + (p:ahead (and pushp p:track + (string-match "ahead \\([0-9]+\\)" p:track) + (magit--propertize-face + (concat (match-string 1 p:track) + ">" + (and magit-refs-pad-commit-counts " ")) + 'magit-branch-remote))) + (p:behind (and pushp p:track + (string-match "behind \\([0-9]+\\)" p:track) + (magit--propertize-face + (concat "<" + (match-string 1 p:track) + (and magit-refs-pad-commit-counts " ")) + 'magit-dimmed)))) + (list (1+ (length (concat branch-pretty u:ahead p:ahead u:behind))) + branch + (magit-refs--format-focus-column branch headp) + branch-pretty u:ahead p:ahead + u:behind + (and upstream + (concat (if (equal u:track "[gone]") + (magit--propertize-face upstream 'error) + (magit-refs--propertize-branch upstream u:ref)) + " ")) + (and pushp + (concat p:behind + (magit--propertize-face + push 'magit-branch-remote) + " ")) + (if-let ((magit-refs-show-branch-descriptions) + (desc (magit-get "branch" branch "description"))) + (magit--propertize-face desc 'bold) + (and msg (magit-log--wash-summary msg)))))))) + +(defun magit-refs--format-focus-column (ref &optional type) + (let ((focus magit-buffer-upstream) + (width (if magit-refs-show-commit-count + magit-refs-focus-column-width + 1))) + (format + (format "%%%ss " width) + (cond ((or (equal ref focus) + (and (eq type t) + (equal focus "HEAD"))) + (magit--propertize-face (concat (if (equal focus "HEAD") "@" "*") + (make-string (1- width) ?\s)) + 'magit-section-heading)) + ((if (eq type 'tag) + (eq magit-refs-show-commit-count 'all) + magit-refs-show-commit-count) + (pcase-let ((`(,behind ,ahead) + (magit-rev-diff-count magit-buffer-upstream ref))) + (magit--propertize-face + (cond ((> ahead 0) (concat "<" (number-to-string ahead))) + ((> behind 0) (concat (number-to-string behind) ">")) + (t "=")) + 'magit-dimmed))) + (t ""))))) + +(defun magit-refs--propertize-branch (branch ref &optional head-face) + (let ((face (cdr (cl-find-if (pcase-lambda (`(,re . ,_)) + (string-match-p re ref)) + magit-ref-namespaces)))) + (magit--propertize-face + branch (if head-face (list face head-face) face)))) + +(defun magit-refs--insert-refname-p (refname) + (if-let ((entry (seq-find (pcase-lambda (`(,key . ,_)) + (if (functionp key) + (funcall key refname) + (string-match-p key refname))) + magit-refs-filter-alist))) + (cdr entry) + t)) + +(defun magit-refs--insert-cherry-commits (ref) + (magit-insert-section-body + (let ((start (point)) + (magit-insert-section--current nil)) + (magit-git-wash (apply-partially #'magit-log-wash-log 'cherry) + "cherry" "-v" (magit-abbrev-arg) magit-buffer-upstream ref) + (if (= (point) start) + (message "No cherries for %s" ref) + (magit-make-margin-overlay))))) + +(defun magit-refs--format-margin (commit) + (if-let ((line (magit-rev-format "%cN%x00%ct" commit))) + (apply #'magit-log-format-margin commit (split-string line "\0")) + (magit-make-margin-overlay))) + +;;; _ +(provide 'magit-refs) +;;; magit-refs.el ends here blob - /dev/null blob + e4cdab797d2968fe876b58d775b881df08c73d4c (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-remote.el @@ -0,0 +1,396 @@ +;;; magit-remote.el --- Transfer Git commits -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements remote commands. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-remote-add-set-remote.pushDefault 'ask-if-unset + "Whether to set the value of `remote.pushDefault' after adding a remote. + +If `ask', then always ask. If `ask-if-unset', then ask, but only +if the variable isn't set already. If nil, then don't ever set. +If the value is a string, then set without asking, provided that +the name of the added remote is equal to that string and the +variable isn't already set." + :package-version '(magit . "2.4.0") + :group 'magit-commands + :type '(choice (const :tag "Ask if unset" ask-if-unset) + (const :tag "Always ask" ask) + (string :tag "Set if named") + (const :tag "Don't set"))) + +(defcustom magit-remote-direct-configure t + "Whether the command `magit-remote' shows Git variables. +When set to nil, no variables are displayed by this transient +command, instead the sub-transient `magit-remote-configure' +has to be used to view and change remote related variables." + :package-version '(magit . "2.12.0") + :group 'magit-commands + :type 'boolean) + +(defcustom magit-prefer-push-default nil + "Whether to prefer `remote.pushDefault' over per-branch variables." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'boolean) + +;;; Commands + +;;;###autoload (autoload 'magit-remote "magit-remote" nil t) +(transient-define-prefix magit-remote (remote) + "Add, configure or remove a remote." + :man-page "git-remote" + :value '("-f") + ["Variables" + :if (##and magit-remote-direct-configure (transient-scope)) + ("u" magit-remote..url) + ("U" magit-remote..fetch) + ("s" magit-remote..pushurl) + ("S" magit-remote..push) + ("O" magit-remote..tagopt)] + ["Arguments for add" + ("-f" "Fetch after add" "-f")] + ["Actions" + [("a" "Add" magit-remote-add) + ("r" "Rename" magit-remote-rename) + ("k" "Remove" magit-remote-remove)] + [("C" "Configure..." magit-remote-configure) + ("p" "Prune stale branches" magit-remote-prune) + ("P" "Prune stale refspecs" magit-remote-prune-refspecs) + (7 "z" "Unshallow remote" magit-remote-unshallow)] + [("d u" magit-update-default-branch)]] + (interactive (list (magit-get-current-remote))) + (transient-setup 'magit-remote nil nil :scope remote)) + +(defun magit-read-url (prompt &optional initial-input) + (let ((url (magit-read-string-ns prompt initial-input))) + (if (string-prefix-p "~" url) + (expand-file-name url) + url))) + +;;;###autoload +(defun magit-remote-add (remote url &optional args) + "Add a remote named REMOTE and fetch it." + (interactive + (let ((origin (magit-get "remote.origin.url")) + (remote (magit-read-string-ns "Remote name"))) + (list remote + (magit-read-url + "Remote url" + (and origin + (string-match "\\([^:/]+\\)/[^/]+\\(\\.git\\)?\\'" origin) + (replace-match remote t t origin 1))) + (transient-args 'magit-remote)))) + (if (pcase (list magit-remote-add-set-remote.pushDefault + (magit-get "remote.pushDefault")) + (`(,(pred stringp) ,_) t) + ((or `(ask ,_) '(ask-if-unset nil)) + (y-or-n-p (format "Set `remote.pushDefault' to \"%s\"? " remote)))) + (progn (magit-call-git "remote" "add" args remote url) + (setf (magit-get "remote.pushDefault") remote) + (magit-refresh)) + (magit-run-git-async "remote" "add" args remote url))) + +;;;###autoload +(defun magit-remote-rename (old new) + "Rename the remote named OLD to NEW." + (interactive + (let ((remote (magit-read-remote "Rename remote"))) + (list remote (magit-read-string-ns (format "Rename %s to" remote))))) + (unless (string= old new) + (magit-call-git "remote" "rename" old new) + (magit-remote--cleanup-push-variables old new) + (magit-refresh))) + +;;;###autoload +(defun magit-remote-remove (remote) + "Delete the remote named REMOTE." + (interactive (list (magit-read-remote "Delete remote"))) + (magit-call-git "remote" "rm" remote) + (magit-remote--cleanup-push-variables remote) + (magit-refresh)) + +(defun magit-remote--cleanup-push-variables (remote &optional new-name) + (magit-with-toplevel + (when (equal (magit-get "remote.pushDefault") remote) + (magit-set new-name "remote.pushDefault")) + (dolist (var (magit-git-lines "config" "--name-only" + "--get-regexp" "^branch\\.[^.]*\\.pushRemote" + (format "^%s$" remote))) + (magit-call-git "config" (and (not new-name) "--unset") var new-name)))) + +(defconst magit--refspec-re "\\`\\(\\+\\)?\\([^:]+\\):\\(.*\\)\\'") + +;;;###autoload +(defun magit-remote-prune (remote) + "Remove stale remote-tracking branches for REMOTE." + (interactive (list (magit-read-remote "Prune stale branches of remote"))) + (magit-run-git-async "remote" "prune" remote)) + +;;;###autoload +(defun magit-remote-prune-refspecs (remote) + "Remove stale refspecs for REMOTE. + +A refspec is stale if there no longer exists at least one branch +on the remote that would be fetched due to that refspec. A stale +refspec is problematic because its existence causes Git to refuse +to fetch according to the remaining non-stale refspecs. + +If only stale refspecs remain, then offer to either delete the +remote or to replace the stale refspecs with the default refspec. + +Also remove the remote-tracking branches that were created due to +the now stale refspecs. Other stale branches are not removed." + (interactive (list (magit-read-remote "Prune refspecs of remote"))) + (let* ((tracking-refs (magit-list-remote-branches remote)) + (remote-refs (magit-remote-list-refs remote)) + (variable (format "remote.%s.fetch" remote)) + (refspecs (magit-get-all variable)) + stale) + (dolist (refspec refspecs) + (when (string-match magit--refspec-re refspec) + (let ((theirs (match-string 2 refspec)) + (ours (match-string 3 refspec))) + (unless (if (string-match "\\*" theirs) + (let ((re (replace-match ".*" t t theirs))) + (seq-some (##string-match-p re %) remote-refs)) + (member theirs remote-refs)) + (push (cons refspec + (if (string-match "\\*" ours) + (let ((re (replace-match ".*" t t ours))) + (seq-filter (##string-match-p re %) + tracking-refs)) + (list (car (member ours tracking-refs))))) + stale))))) + (if (not stale) + (message "No stale refspecs for remote %S" remote) + (if (= (length stale) + (length refspecs)) + (magit-read-char-case + (format "All of %s's refspecs are stale. " remote) nil + (?s "replace with [d]efault refspec" + (magit-set-all + (list (format "+refs/heads/*:refs/remotes/%s/*" remote)) + variable)) + (?r "[r]emove remote" + (magit-call-git "remote" "rm" remote)) + (?a "[a]abort" + (user-error "Abort"))) + (if (if (length= stale 1) + (pcase-let ((`(,refspec . ,refs) (car stale))) + (magit-confirm 'prune-stale-refspecs + (list "Prune stale refspec %s and branch %%s" refspec) + (list "Prune stale refspec %s and %%d branches" refspec) + nil refs)) + (magit-confirm 'prune-stale-refspecs nil + (format "Prune %%d stale refspecs and %d branches" + (length (mapcan (##copy-sequence (cdr %)) stale))) + nil + (mapcar (pcase-lambda (`(,refspec . ,refs)) + (concat refspec "\n" + (mapconcat (##concat " " %) refs "\n"))) + stale))) + (pcase-dolist (`(,refspec . ,refs) stale) + (magit-call-git "config" "--unset" variable + (regexp-quote refspec)) + (magit--log-action + (lambda (refs) + (format "Deleting %d branches" (length refs))) + (lambda (ref) + (format "Deleting branch %s (was %s)" ref + (magit-rev-parse "--short" ref))) + refs) + (dolist (ref refs) + (magit-call-git "update-ref" "-d" ref))) + (user-error "Abort"))) + (magit-refresh)))) + +;;;###autoload +(defun magit-remote-set-head (remote &optional branch) + "Set the local representation of REMOTE's default branch. +Query REMOTE and set the symbolic-ref refs/remotes//HEAD +accordingly. With a prefix argument query for the branch to be +used, which allows you to select an incorrect value if you fancy +doing that." + (interactive + (let ((remote (magit-read-remote "Set HEAD for remote"))) + (list remote + (and current-prefix-arg + (magit-read-remote-branch (format "Set %s/HEAD to" remote) + remote nil nil t))))) + (magit-run-git "remote" "set-head" remote (or branch "--auto"))) + +;;;###autoload +(defun magit-remote-unset-head (remote) + "Unset the local representation of REMOTE's default branch. +Delete the symbolic-ref \"refs/remotes//HEAD\"." + (interactive (list (magit-read-remote "Unset HEAD for remote"))) + (magit-run-git "remote" "set-head" remote "--delete")) + +;;;###autoload (autoload 'magit-update-default-branch "magit-remote" nil t) +(transient-define-suffix magit-update-default-branch () + "Update name of the default branch after upstream changed it." + :description "Update default branch" + :inapt-if-not #'magit-get-some-remote + (interactive) + (pcase-let ((`(,_remote ,oldname) (magit--get-default-branch)) + (`( ,remote ,newname) (magit--get-default-branch t))) + (cond + ((equal oldname newname) + (setq oldname + (read-string + (format + "Name of default branch is still `%s', %s\n%s `%s': " oldname + "but the upstreams of some local branches might need updating." + "Name of upstream branches to replace with" newname))) + (magit--set-default-branch newname oldname) + (magit-refresh)) + (t + (unless oldname + (setq oldname + (magit-read-other-local-branch + (format "Name of old default branch to be renamed to `%s'" + newname) + newname "master"))) + (cond + ((y-or-n-p (format "Default branch changed from `%s' to `%s' on %s.%s?" + oldname newname remote " Do the same locally")) + (magit--set-default-branch newname oldname) + (magit-refresh)) + ((user-error "Abort"))))))) + +;;;###autoload +(defun magit-remote-unshallow (remote) + "Convert a shallow remote into a full one. +If only a single refspec is set and it does not contain a +wildcard, then also offer to replace it with the standard +refspec." + (interactive (list (or (magit-get-current-remote) + (magit-read-remote "Delete remote")))) + (let ((refspecs (magit-get-all "remote" remote "fetch")) + (standard (format "+refs/heads/*:refs/remotes/%s/*" remote))) + (when (and (length= refspecs 1) + (not (string-search "*" (car refspecs))) + (yes-or-no-p (format "Also replace refspec %s with %s? " + (car refspecs) + standard))) + (magit-set standard "remote" remote "fetch")) + (magit-git-fetch "--unshallow" remote))) + +;;; Configure + +;;;###autoload (autoload 'magit-remote-configure "magit-remote" nil t) +(transient-define-prefix magit-remote-configure (remote) + "Configure a remote." + :man-page "git-remote" + [:description (##concat + (propertize "Configure " 'face 'transient-heading) + (propertize (transient-scope) 'face 'magit-branch-remote)) + ("u" magit-remote..url) + ("U" magit-remote..fetch) + ("s" magit-remote..pushurl) + ("S" magit-remote..push) + ("O" magit-remote..tagopt)] + (interactive + (list (or (and (not current-prefix-arg) + (not (and magit-remote-direct-configure + (eq transient-current-command 'magit-remote))) + (magit-get-current-remote)) + (magit--read-remote-scope)))) + (transient-setup 'magit-remote-configure nil nil :scope remote)) + +(defun magit--read-remote-scope (&optional obj) + (magit-read-remote + (if obj + (format "Set %s for remote" + (format (oref obj variable) "")) + "Configure remote"))) + +(transient-define-infix magit-remote..url () + :class 'magit--git-variable:urls + :scope #'magit--read-remote-scope + :variable "remote.%s.url" + :multi-value t + :history-key 'magit-remote..*url) + +(transient-define-infix magit-remote..fetch () + :class 'magit--git-variable + :scope #'magit--read-remote-scope + :variable "remote.%s.fetch" + :multi-value t) + +(transient-define-infix magit-remote..pushurl () + :class 'magit--git-variable:urls + :scope #'magit--read-remote-scope + :variable "remote.%s.pushurl" + :multi-value t + :history-key 'magit-remote..*url + :seturl-arg "--push") + +(transient-define-infix magit-remote..push () + :class 'magit--git-variable + :scope #'magit--read-remote-scope + :variable "remote.%s.push") + +(transient-define-infix magit-remote..tagopt () + :class 'magit--git-variable:choices + :scope #'magit--read-remote-scope + :variable "remote.%s.tagOpt" + :choices '("--no-tags" "--tags")) + +;;; Transfer Utilities + +(defun magit--push-remote-variable (&optional branch short) + (unless branch + (setq branch (magit-get-current-branch))) + (magit--propertize-face + (if (or (not branch) magit-prefer-push-default) + (if short "pushDefault" "remote.pushDefault") + (if short "pushRemote" (format "branch.%s.pushRemote" branch))) + 'bold)) + +(defun magit--select-push-remote (prompt-suffix) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (remote (magit-get-push-remote branch)) + (changed nil)) + (when (or current-prefix-arg + (not remote) + (not (member remote (magit-list-remotes)))) + (setq changed t) + (setq remote + (magit-read-remote (format "Set %s and %s" + (magit--push-remote-variable) + prompt-suffix))) + (setf (magit-get (magit--push-remote-variable branch)) remote)) + (list branch remote changed))) + +;;; _ +(provide 'magit-remote) +;;; magit-remote.el ends here blob - /dev/null blob + b815757c00a9a771924ce1277ca58210ef3e34bb (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-repos.el @@ -0,0 +1,547 @@ +;;; magit-repos.el --- Listing repositories -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for listing repositories. This +;; includes getting a Lisp list of known repositories as well as a +;; mode for listing repositories in a buffer. + +;;; Code: + +(require 'magit-core) + +(declare-function magit-status-setup-buffer "magit-status" (&optional directory)) + +(defvar x-stretch-cursor) + +;;; Options + +(defcustom magit-repository-directories nil + "List of directories that are or contain Git repositories. + +Each element has the form (DIRECTORY . DEPTH). DIRECTORY has +to be a directory or a directory file-name, a string. DEPTH, +an integer, specifies the maximum depth to look for Git +repositories. If it is 0, then only add DIRECTORY itself. + +This option controls which repositories are being listed by +`magit-list-repositories'. It also affects `magit-status' +\(which see) in potentially surprising ways." + :package-version '(magit . "3.0.0") + :group 'magit-essentials + :type '(repeat (cons directory (integer :tag "Depth")))) + +(defgroup magit-repolist nil + "List repositories in a buffer." + :link '(info-link "(magit)Repository List") + :group 'magit-modes) + +(defcustom magit-repolist-mode-hook (list #'hl-line-mode) + "Hook run after entering Magit-Repolist mode." + :package-version '(magit . "2.9.0") + :group 'magit-repolist + :type 'hook + :get #'magit-hook-custom-get + :options (list #'hl-line-mode)) + +(defcustom magit-repolist-columns + `(("Name" 25 ,#'magit-repolist-column-ident + ()) + ("Version" 25 ,#'magit-repolist-column-version + ((:sort magit-repolist-version<))) + ("BU" 3 ,#'magit-repolist-column-unpushed-to-upstream + (;; (:help-echo "Local changes not in upstream") + (:right-align t) + (:sort <))) + ("Path" 99 ,#'magit-repolist-column-path + ())) + "List of columns displayed by `magit-list-repositories'. + +Each element has the form (HEADER WIDTH FORMAT PROPS). + +HEADER is the string displayed in the header. WIDTH is the width +of the column. FORMAT is a function that is called with one +argument, the repository identification (usually its basename), +and with `default-directory' bound to the toplevel of its working +tree. It has to return a string to be inserted or nil. PROPS is +an alist that supports the keys `:right-align', `:pad-right' and +`:sort'. + +The `:sort' function has a weird interface described in the +docstring of `tabulated-list--get-sort'. Alternatively `<' and +`magit-repolist-version<' can be used as those functions are +automatically replaced with functions that satisfy the interface. +Set `:sort' to nil to inhibit sorting; if unspecified, then the +column is sortable using the default sorter. + +You may wish to display a range of numeric columns using just one +character per column and without any padding between columns, in +which case you should use an appropriate HEADER, set WIDTH to 1, +and set `:pad-right' to 0. \"+\" is substituted for numbers higher +than 9." + :package-version '(magit . "2.12.0") + :group 'magit-repolist + :type '(repeat (list :tag "Column" + (string :tag "Header Label") + (integer :tag "Column Width") + (function :tag "Inserter Function") + (repeat :tag "Properties" + (list (choice :tag "Property" + (const :right-align) + (const :pad-right) + (const :sort) + (symbol)) + (sexp :tag "Value")))))) + +(defcustom magit-repolist-column-flag-alist + `((,#'magit-untracked-files . "N") + (,#'magit-unstaged-files . "U") + (,#'magit-staged-files . "S")) + "Association list of predicates and flags for `magit-repolist-column-flag'. + +Each element is of the form (FUNCTION . FLAG). Each FUNCTION is +called with no arguments, with `default-directory' bound to the +top level of a repository working tree, until one of them returns +a non-nil value. FLAG corresponding to that function is returned +as the value of `magit-repolist-column-flag'." + :package-version '(magit . "3.0.0") + :group 'magit-repolist + :type '(alist :key-type (function :tag "Predicate Function") + :value-type (string :tag "Flag"))) + +(defcustom magit-repolist-sort-key '("Path" . nil) + "Initial sort key for buffer created by `magit-list-repositories'. +If nil, no additional sorting is performed. Otherwise, this +should be a cons cell (NAME . FLIP). NAME is a string matching +one of the column names in `magit-repolist-columns'. FLIP, if +non-nil, means to invert the resulting sort." + :package-version '(magit . "3.2.0") + :group 'magit-repolist + :type '(choice (const nil) + (cons (string :tag "Column name") + (boolean :tag "Flip order")))) + +;;; List Repositories +;;;; List Commands +;;;###autoload +(defun magit-list-repositories () + "Display a list of repositories. + +Use the option `magit-repository-directories' to control which +repositories are displayed." + (interactive) + (magit-repolist-setup (default-value 'magit-repolist-columns))) + +;;;; Mode Commands + +(defun magit-repolist-status (&optional _button) + "Show the status for the repository at point." + (interactive) + (if-let ((id (tabulated-list-get-id))) + (magit-status-setup-buffer (expand-file-name id)) + (user-error "There is no repository at point"))) + +(defun magit-repolist-mark () + "Mark a repository and move to the next line." + (interactive) + (magit-repolist--ensure-padding) + (tabulated-list-put-tag "*" t)) + +(defun magit-repolist-unmark () + "Unmark a repository and move to the next line." + (interactive) + (tabulated-list-put-tag " " t)) + +(defun magit-repolist-fetch (repos) + "Fetch all marked or listed repositories." + (interactive (list (magit-repolist--get-repos ?*))) + (run-hooks 'magit-credential-hook) + (magit-repolist--mapc (##magit-run-git "remote" "update") + repos "Fetching in %s...")) + +(defun magit-repolist-find-file-other-frame (repos file) + "Find a file in all marked or listed repositories." + (interactive (list (magit-repolist--get-repos ?*) + (read-string "Find file in repositories: "))) + (magit-repolist--mapc (##find-file-other-frame file) repos)) + +(defun magit-repolist--ensure-padding () + "Set `tabulated-list-padding' to 2, unless that is already non-zero." + (when (zerop tabulated-list-padding) + (setq tabulated-list-padding 2) + (tabulated-list-init-header) + (tabulated-list-print t))) + +(defun magit-repolist--get-repos (&optional char) + "Return marked repositories or `all' if none are marked. +If optional CHAR is non-nil, then only return repositories +marked with that character. If no repositories are marked +then ask whether to act on all repositories instead." + (or (magit-repolist--marked-repos char) + (if (magit-confirm 'repolist-all + "Nothing selected. Act on ALL displayed repositories") + 'all + (user-error "Abort")))) + +(defun magit-repolist--marked-repos (&optional char) + "Return marked repositories. +If optional CHAR is non-nil, then only return repositories +marked with that character." + (let (c list) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq c (char-after)) + (unless (eq c ?\s) + (if char + (when (eq c char) + (push (tabulated-list-get-id) list)) + (push (cons c (tabulated-list-get-id)) list))) + (forward-line))) + list)) + +(defun magit-repolist--mapc (fn repos &optional msg) + "Apply FN to each directory in REPOS for side effects only. +If REPOS is the symbol `all', then call FN for all displayed +repositories. When FN is called, `default-directory' is bound to +the top-level directory of the current repository. If optional +MSG is non-nil then that is displayed around each call to FN. +If it contains \"%s\" then the directory is substituted for that." + (when (eq repos 'all) + (setq repos nil) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (push (tabulated-list-get-id) repos) + (forward-line))) + (setq repos (nreverse repos))) + (let ((base default-directory) + (len (length repos)) + (i 0)) + (dolist (repo repos) + (let ((default-directory + (file-name-as-directory (expand-file-name repo base)))) + (if msg + (let ((msg (concat (format "(%s/%s) " (cl-incf i) len) + (format msg default-directory)))) + (message msg) + (funcall fn) + (message (concat msg "done"))) + (funcall fn)))))) + +;;;; Mode + +(defvar-keymap magit-repolist-mode-map + :doc "Local keymap for Magit-Repolist mode buffers." + :parent tabulated-list-mode-map + "C-m" #'magit-repolist-status + "m" #'magit-repolist-mark + "u" #'magit-repolist-unmark + "f" #'magit-repolist-fetch + "5" #'magit-repolist-find-file-other-frame) + +(define-derived-mode magit-repolist-mode tabulated-list-mode "Repos" + "Major mode for browsing a list of Git repositories." + :interactive nil + :group 'magit-repolist + (setq-local x-stretch-cursor nil) + (setq tabulated-list-padding 0) + (setq-local tabulated-list-revert-hook (list #'magit-repolist-refresh t)) + (setq imenu-prev-index-position-function + #'magit-repolist--imenu-prev-index-position) + (setq imenu-extract-index-name-function #'tabulated-list-get-id)) + +(defun magit-repolist-setup (columns) + (unless magit-repository-directories + (user-error "You need to customize `magit-repository-directories' %s" + "before you can list repositories")) + (with-current-buffer (get-buffer-create "*Magit Repositories*") + (magit-repolist-mode) + (setq-local magit-repolist-columns columns) + (magit-repolist-setup-1) + (magit-repolist-refresh) + (switch-to-buffer (current-buffer)))) + +(defun magit-repolist-setup-1 () + (unless tabulated-list-sort-key + (setq tabulated-list-sort-key + (pcase-let ((`(,column . ,flip) magit-repolist-sort-key)) + (cons (or (car (assoc column magit-repolist-columns)) + (caar magit-repolist-columns)) + flip)))) + (setq tabulated-list-format + (vconcat (seq-map-indexed + (lambda (column idx) + (pcase-let* ((`(,title ,width ,_fn ,props) column) + (sort-set (assoc :sort props)) + (sort-fn (cadr sort-set))) + (nconc (list title width + (cond ((eq sort-fn '<) + (magit-repolist-make-sorter + sort-fn #'string-to-number idx)) + ((eq sort-fn 'magit-repolist-version<) + (magit-repolist-make-sorter + sort-fn #'identity idx)) + (sort-fn sort-fn) + (sort-set nil) + (t t))) + (flatten-tree props)))) + magit-repolist-columns)))) + +(defun magit-repolist-refresh () + (setq tabulated-list-entries + (mapcar (pcase-lambda (`(,id . ,path)) + (let ((default-directory path)) + (list path + (vconcat + (mapcar (pcase-lambda (`(,title ,width ,fn ,props)) + (or (funcall fn `((:id ,id) + (:title ,title) + (:width ,width) + ,@props)) + "")) + magit-repolist-columns))))) + (magit-list-repos-uniquify + (mapcar (##cons (file-name-nondirectory (directory-file-name %)) + %) + (magit-list-repos))))) + (message "Listing repositories...") + (tabulated-list-init-header) + (tabulated-list-print t) + (message "Listing repositories...done")) + +(defun magit-repolist--imenu-prev-index-position () + (and (not (bobp)) + (forward-line -1))) + +;;;; Columns + +(defun magit-repolist-make-sorter (sort-predicate convert-cell column-idx) + "Return a function suitable as a sorter for tabulated lists. +See `tabulated-list--get-sorter'. Given a more reasonable API +this would not be necessary and one could just use SORT-PREDICATE +directly. CONVERT-CELL can be used to turn the cell value, which +is always a string back into, e.g., a number. COLUMN-IDX has to +be the index of the column that uses the returned sorter function." + (lambda (a b) + (funcall sort-predicate + (funcall convert-cell (aref (cadr a) column-idx)) + (funcall convert-cell (aref (cadr b) column-idx))))) + +(defun magit-repolist-column-ident (spec) + "Insert the identification of the repository. +Usually this is just its basename." + (cadr (assq :id spec))) + +(defun magit-repolist-column-path (_) + "Insert the absolute path of the repository." + (abbreviate-file-name default-directory)) + +(defvar magit-repolist-column-version-regexp "\ +\\(?1:-\\(?2:[0-9]*\\)\ +\\(?3:-g[a-z0-9]*\\)\\)?\ +\\(?:-\\(?4:dirty\\)\\)\ +?\\'") + +(defvar magit-repolist-column-version-resume-regexp + "\\`Resume development\\'") + +(defun magit-repolist-column-version (_) + "Insert a description of the repository's `HEAD' revision." + (and-let* ((v (or (magit-git-string "describe" "--tags" "--dirty") + ;; If there are no tags, use the date in MELPA format. + (magit-rev-format "%cd-g%h" nil + "--date=format:%Y%m%d.%H%M")))) + (save-match-data + (when (string-match magit-repolist-column-version-regexp v) + (magit--put-face (match-beginning 0) (match-end 0) 'shadow v) + (when (match-end 2) + (magit--put-face (match-beginning 2) (match-end 2) 'bold v)) + (when (match-end 4) + (magit--put-face (or (match-beginning 3) (match-beginning 4)) + (match-end 4) 'error v)) + (when (and (equal (match-string 2 v) "1") + (string-match-p magit-repolist-column-version-resume-regexp + (magit-rev-format "%s"))) + (setq v (replace-match (propertize "+" 'face 'shadow) t t v 1)))) + (if (and v (string-match "\\`[0-9]" v)) + (concat " " v) + (when (and v (string-match "\\`[^0-9]+" v)) + (magit--put-face 0 (match-end 0) 'shadow v)) + v)))) + +(defun magit-repolist-version< (a b) + (save-match-data + (let ((re "[0-9]+\\(\\.[0-9]*\\)*")) + (setq a (and (string-match re a) (match-string 0 a))) + (setq b (and (string-match re b) (match-string 0 b))) + (cond ((and a b) (version< a b)) + (b nil) + (t t))))) + +(defun magit-repolist-column-branch (_) + "Insert the current branch." + (let ((branch (magit-get-current-branch))) + (if (member branch magit-main-branch-names) + (magit--propertize-face branch 'shadow) + branch))) + +(defun magit-repolist-column-upstream (_) + "Insert the upstream branch of the current branch." + (magit-get-upstream-branch)) + +(defun magit-repolist-column-flag (_) + "Insert a flag as specified by `magit-repolist-column-flag-alist'. + +By default this indicates whether there are uncommitted changes. +- N if there is at least one untracked file. +- U if there is at least one unstaged file. +- S if there is at least one staged file. +Only one letter is shown, the first that applies." + (seq-some (pcase-lambda (`(,fun . ,flag)) + (and (funcall fun) flag)) + magit-repolist-column-flag-alist)) + +(defun magit-repolist-column-flags (_) + "Insert all flags as specified by `magit-repolist-column-flag-alist'. +This is an alternative to function `magit-repolist-column-flag', +which only lists the first one found." + (mapconcat (pcase-lambda (`(,fun . ,flag)) + (if (funcall fun) flag " ")) + magit-repolist-column-flag-alist + "")) + +(defun magit-repolist-column-unpulled-from-upstream (spec) + "Insert number of upstream commits not in the current branch." + (and-let* ((br (magit-get-upstream-branch))) + (magit-repolist-insert-count (cadr (magit-rev-diff-count "HEAD" br)) spec))) + +(defun magit-repolist-column-unpulled-from-pushremote (spec) + "Insert number of commits in the push branch but not the current branch." + (and-let* ((br (magit-get-push-branch nil t))) + (magit-repolist-insert-count (cadr (magit-rev-diff-count "HEAD" br)) spec))) + +(defun magit-repolist-column-unpushed-to-upstream (spec) + "Insert number of commits in the current branch but not its upstream." + (and-let* ((br (magit-get-upstream-branch))) + (magit-repolist-insert-count (car (magit-rev-diff-count "HEAD" br)) spec))) + +(defun magit-repolist-column-unpushed-to-pushremote (spec) + "Insert number of commits in the current branch but not its push branch." + (and-let* ((br (magit-get-push-branch nil t))) + (magit-repolist-insert-count (car (magit-rev-diff-count "HEAD" br)) spec))) + +(defun magit-repolist-column-branches (spec) + "Insert number of branches." + (magit-repolist-insert-count (length (magit-list-local-branches)) + `((:normal-count 1) ,@spec))) + +(defun magit-repolist-column-stashes (spec) + "Insert number of stashes." + (magit-repolist-insert-count (length (magit-list-stashes)) spec)) + +(defun magit-repolist-insert-count (n spec) + (magit--propertize-face + (if (and (> n 9) (= (cadr (assq :width spec)) 1)) + "+" + (number-to-string n)) + (if (> n (or (cadr (assq :normal-count spec)) 0)) 'bold 'shadow))) + +;;; Read Repository + +(defun magit-read-repository (&optional read-directory-name) + "Read a Git repository in the minibuffer, with completion. + +The completion choices are the basenames of top-levels of +repositories found in the directories specified by option +`magit-repository-directories'. In case of name conflicts +the basenames are prefixed with the name of the respective +parent directories. The returned value is the actual path +to the selected repository. + +If READ-DIRECTORY-NAME is non-nil or no repositories can be +found based on the value of `magit-repository-directories', +then read an arbitrary directory using `read-directory-name' +instead." + (if-let ((repos (and (not read-directory-name) + magit-repository-directories + (magit-repos-alist)))) + (let ((reply (magit-completing-read "Git repository" repos))) + (file-name-as-directory + (or (cdr (assoc reply repos)) + (if (file-directory-p reply) + (expand-file-name reply) + (user-error "Not a repository or a directory: %s" reply))))) + (file-name-as-directory + (read-directory-name "Git repository: " + (or (magit-toplevel) default-directory))))) + +(defun magit-list-repos () + (mapcan (pcase-lambda (`(,dir . ,depth)) + (magit-list-repos-1 dir depth)) + magit-repository-directories)) + +(defun magit-list-repos-1 (directory depth) + (cond ((file-readable-p (expand-file-name ".git" directory)) + (list (file-name-as-directory directory))) + ((and (> depth 0) (file-accessible-directory-p directory)) + (mapcan (##and (file-directory-p %) + (magit-list-repos-1 % (1- depth))) + (directory-files directory t + directory-files-no-dot-files-regexp t))))) + +(defun magit-list-repos-uniquify (alist) + (let (result (dict (make-hash-table :test #'equal))) + (dolist (a (delete-dups alist)) + (puthash (car a) (cons (cdr a) (gethash (car a) dict)) dict)) + (maphash + (lambda (key value) + (if (length= value 1) + (push (cons key (car value)) result) + (setq result + (append + result + (magit-list-repos-uniquify + (mapcar (lambda (v) + (cons (concat + key "\\" + (file-name-nondirectory + (directory-file-name + (substring v 0 (- (1+ (length key))))))) + v)) + value)))))) + dict) + result)) + +(defun magit-repos-alist () + (magit-list-repos-uniquify + (mapcar (##cons (file-name-nondirectory (directory-file-name %)) %) + (magit-list-repos)))) + +;;; _ +(provide 'magit-repos) +;;; magit-repos.el ends here blob - /dev/null blob + 4baa64b26e8d33696ef08c53e04db186fdba645a (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-reset.el @@ -0,0 +1,137 @@ +;;; magit-reset.el --- Reset functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements reset commands. + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-reset "magit" nil t) +(transient-define-prefix magit-reset () + "Reset the `HEAD', index and/or worktree to a previous state." + :man-page "git-reset" + [["Reset" + ("b" "branch" magit-branch-reset) + ("f" "file" magit-file-checkout)] + ["Reset this" + ("m" "mixed (HEAD and index)" magit-reset-mixed) + ("s" "soft (HEAD only)" magit-reset-soft) + ("h" "hard (HEAD, index and worktree)" magit-reset-hard) + ("k" "keep (HEAD and index, keeping uncommitted)" magit-reset-keep) + ("i" "index (only)" magit-reset-index) + ("w" "worktree (only)" magit-reset-worktree)]]) + +;;;###autoload +(defun magit-reset-mixed (commit) + "Reset the `HEAD' and index to COMMIT, but not the working tree. +\n(git reset --mixed COMMIT)" + (interactive (list (magit-reset-read-branch-or-commit "Reset %s to"))) + (magit-reset-internal "--mixed" commit)) + +;;;###autoload +(defun magit-reset-soft (commit) + "Reset the `HEAD' to COMMIT, but not the index and working tree. +\n(git reset --soft REVISION)" + (interactive (list (magit-reset-read-branch-or-commit "Soft reset %s to"))) + (magit-reset-internal "--soft" commit)) + +;;;###autoload +(defun magit-reset-hard (commit) + "Reset the `HEAD', index, and working tree to COMMIT. +\n(git reset --hard REVISION)" + (interactive (list (magit-reset-read-branch-or-commit + (concat (magit--propertize-face "Hard" 'bold) + " reset %s to")))) + (magit-reset-internal "--hard" commit)) + +;;;###autoload +(defun magit-reset-keep (commit) + "Reset the `HEAD' and index to COMMIT, while keeping uncommitted changes. +\n(git reset --keep REVISION)" + (interactive (list (magit-reset-read-branch-or-commit "Reset %s to"))) + (magit-reset-internal "--keep" commit)) + +;;;###autoload +(defun magit-reset-index (commit) + "Reset the index to COMMIT. +Keep the `HEAD' and working tree as-is, so if COMMIT refers to the +head this effectively unstages all changes. +\n(git reset COMMIT .)" + (interactive (list (magit-read-branch-or-commit "Reset index to"))) + (magit-reset-internal nil commit ".")) + +;;;###autoload +(defun magit-reset-worktree (commit) + "Reset the worktree to COMMIT. +Keep the `HEAD' and index as-is." + (interactive (list (magit-read-branch-or-commit "Reset worktree to"))) + (magit-wip-commit-before-change nil " before reset") + (magit-with-temp-index commit nil + (magit-call-git "checkout-index" "--all" "--force")) + (magit-wip-commit-after-apply nil " after reset") + (magit-refresh)) + +;;;###autoload +(defun magit-reset-quickly (commit &optional hard) + "Reset the `HEAD' and index to COMMIT, and possibly the working tree. +With a prefix argument reset the working tree otherwise don't. +\n(git reset --mixed|--hard COMMIT)" + (interactive (list (magit-reset-read-branch-or-commit + (if current-prefix-arg + (concat (magit--propertize-face "Hard" 'bold) + " reset %s to") + "Reset %s to")) + current-prefix-arg)) + (magit-reset-internal (if hard "--hard" "--mixed") commit)) + +(defun magit-reset-read-branch-or-commit (prompt) + "Prompt for and return a ref to reset HEAD to. + +PROMPT is a format string, where either the current branch name +or \"detached head\" will be substituted for %s." + (magit-read-branch-or-commit + (format prompt (or (magit-get-current-branch) "detached head")))) + +(defun magit-reset-internal (arg commit &optional path) + (when (and (not (member arg '("--hard" nil))) + (equal (magit-rev-parse commit) + (magit-rev-parse "HEAD~"))) + (with-temp-buffer + (magit-git-insert "show" "-s" "--format=%B" "HEAD") + (when git-commit-major-mode + (funcall git-commit-major-mode)) + (git-commit-setup-font-lock) + (git-commit-save-message))) + (let ((cmd (if (and (equal commit "HEAD") (not arg)) "unstage" "reset"))) + (magit-wip-commit-before-change nil (concat " before " cmd)) + (magit-run-git "reset" arg commit "--" path) + (when (equal cmd "unstage") + (magit-wip-commit-after-apply nil " after unstage")))) + +;;; _ +(provide 'magit-reset) +;;; magit-reset.el ends here blob - /dev/null blob + 757bd5965b3f229ef39a76f23ac48d1237b077b4 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-sequence.el @@ -0,0 +1,1144 @@ +;;; magit-sequence.el --- History manipulation in Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Support for Git commands that replay commits and help the user make +;; changes along the way. Supports `cherry-pick', `revert', `rebase', +;; `rebase--interactive' and `am'. + +;;; Code: + +(require 'magit) + +;; For `magit-rebase--todo'. +(declare-function git-rebase-current-line "git-rebase" (&optional batch)) +(eval-when-compile + (cl-pushnew 'action-type eieio--known-slot-names) + (cl-pushnew 'action eieio--known-slot-names) + (cl-pushnew 'action-options eieio--known-slot-names) + (cl-pushnew 'target eieio--known-slot-names)) + +;;; Options +;;;; Faces + +(defface magit-sequence-pick + '((t :inherit default)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-stop + '((((class color) (background light)) :foreground "DarkOliveGreen4") + (((class color) (background dark)) :foreground "DarkSeaGreen2")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-part + '((((class color) (background light)) :foreground "Goldenrod4") + (((class color) (background dark)) :foreground "LightGoldenrod2")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-head + '((((class color) (background light)) :foreground "SkyBlue4") + (((class color) (background dark)) :foreground "LightSkyBlue1")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-drop + '((((class color) (background light)) :foreground "IndianRed") + (((class color) (background dark)) :foreground "IndianRed")) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-done + '((t :inherit magit-hash)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-onto + '((t :inherit magit-sequence-done)) + "Face used in sequence sections." + :group 'magit-faces) + +(defface magit-sequence-exec + '((t :inherit magit-hash)) + "Face used in sequence sections." + :group 'magit-faces) + +;;; Common + +;;;###autoload +(defun magit-sequencer-continue () + "Resume the current cherry-pick or revert sequence." + (interactive) + (cond + ((not (magit-sequencer-in-progress-p)) + (user-error "No cherry-pick or revert in progress")) + ((magit-anything-unmerged-p) + (user-error "Cannot continue due to unresolved conflicts")) + ((magit-run-git-sequencer + (if (magit-revert-in-progress-p) "revert" "cherry-pick") "--continue")))) + +;;;###autoload +(defun magit-sequencer-skip () + "Skip the stopped at commit during a cherry-pick or revert sequence." + (interactive) + (unless (magit-sequencer-in-progress-p) + (user-error "No cherry-pick or revert in progress")) + (magit-call-git "reset" "--hard") + (magit-sequencer-continue)) + +;;;###autoload +(defun magit-sequencer-abort () + "Abort the current cherry-pick or revert sequence. +This discards all changes made since the sequence started." + (interactive) + (cond + ((not (magit-sequencer-in-progress-p)) + (user-error "No cherry-pick or revert in progress")) + ((magit-revert-in-progress-p) + (magit-confirm 'abort-revert "Really abort revert") + (magit-run-git-sequencer "revert" "--abort")) + ((magit-confirm 'abort-cherry-pick "Really abort cherry-pick") + (magit-run-git-sequencer "cherry-pick" "--abort")))) + +(defun magit-sequencer-in-progress-p () + (or (magit-cherry-pick-in-progress-p) + (magit-revert-in-progress-p))) + +;;; Cherry-Pick + +(defvar magit-perl-executable "perl" + "The Perl executable.") + +;;;###autoload (autoload 'magit-cherry-pick "magit-sequence" nil t) +(transient-define-prefix magit-cherry-pick () + "Apply or transplant commits." + :man-page "git-cherry-pick" + :value '("--ff") + :incompatible '(("--ff" "-x")) + ["Arguments" + :if-not magit-sequencer-in-progress-p + (magit-cherry-pick:--mainline) + ("=s" magit-merge:--strategy) + ("-F" "Attempt fast-forward" "--ff") + ("-x" "Reference cherry in commit message" "-x") + ("-e" "Edit commit messages" ("-e" "--edit")) + (magit:--gpg-sign) + (magit:--signoff)] + [:if-not magit-sequencer-in-progress-p + ["Apply here" + ("A" "Pick" magit-cherry-copy) + ("a" "Apply" magit-cherry-apply) + ("h" "Harvest" magit-cherry-harvest) + ("m" "Squash" magit-merge-squash)] + ["Apply elsewhere" + ("d" "Donate" magit-cherry-donate) + ("n" "Spinout" magit-cherry-spinout) + ("s" "Spinoff" magit-cherry-spinoff)]] + ["Actions" + :if magit-sequencer-in-progress-p + ("A" "Continue" magit-sequencer-continue) + ("s" "Skip" magit-sequencer-skip) + ("a" "Abort" magit-sequencer-abort)]) + +(transient-define-argument magit-cherry-pick:--mainline () + :description "Replay merge relative to parent" + :class 'transient-option + :shortarg "-m" + :argument "--mainline=" + :reader #'transient-read-number-N+) + +(defun magit-cherry-pick-read-args (prompt) + (list (or (nreverse (magit-region-values 'commit)) + (magit-read-other-branch-or-commit prompt)) + (transient-args 'magit-cherry-pick))) + +(defun magit--cherry-move-read-args (verb away fn &optional allow-detached) + (declare (indent defun)) + (let ((commits (or (nreverse (magit-region-values 'commit)) + (list (funcall (if away + #'magit-read-branch-or-commit + #'magit-read-other-branch-or-commit) + (format "%s cherry" (capitalize verb)))))) + (current (or (magit-get-current-branch) + (and allow-detached (magit-rev-parse "HEAD"))))) + (unless current + (user-error "Cannot %s cherries while HEAD is detached" verb)) + (let ((reachable (magit-rev-ancestor-p (car commits) current)) + (msg "Cannot %s cherries that %s reachable from HEAD")) + (pcase (list away reachable) + ('(nil t) (user-error msg verb "are")) + ('(t nil) (user-error msg verb "are not")))) + `(,commits + ,@(funcall fn commits) + ,(transient-args 'magit-cherry-pick)))) + +(defun magit--cherry-spinoff-read-args (verb) + (magit--cherry-move-read-args verb t + (lambda (commits) + (magit-branch-read-args + (format "Create branch from %s cherries" (length commits)) + (magit-get-upstream-branch))))) + +;;;###autoload +(defun magit-cherry-copy (commits &optional args) + "Copy COMMITS from another branch onto the current branch. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then pick all of them, +without prompting." + (interactive (magit-cherry-pick-read-args "Cherry-pick")) + (magit--cherry-pick commits args)) + +;;;###autoload +(defun magit-cherry-apply (commits &optional args) + "Apply the changes in COMMITS but do not commit them. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then apply all of them, +without prompting." + (interactive (magit-cherry-pick-read-args "Apply changes from commit")) + (magit--cherry-pick commits (cons "--no-commit" (remove "--ff" args)))) + +;;;###autoload +(defun magit-cherry-harvest (commits branch &optional args) + "Move COMMITS from another BRANCH onto the current branch. +Remove the COMMITS from BRANCH and stay on the current branch. +If a conflict occurs, then you have to fix that and finish the +process manually." + (interactive + (magit--cherry-move-read-args "harvest" nil + (lambda (commits) + (list (let ((branches (magit-list-containing-branches (car commits)))) + (pcase (length branches) + (0 nil) + (1 (car branches)) + (_ (magit-completing-read + (let ((len (length commits))) + (if (= len 1) + "Remove 1 cherry from branch" + (format "Remove %s cherries from branch" len))) + branches nil t)))))))) + (magit--cherry-move commits branch (magit-get-current-branch) args nil t)) + +;;;###autoload +(defun magit-cherry-donate (commits branch &optional args) + "Move COMMITS from the current branch onto another existing BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually. `HEAD' is allowed to be detached initially." + (interactive + (magit--cherry-move-read-args "donate" t + (lambda (commits) + (list (magit-read-other-branch + (let ((len (length commits))) + (if (= len 1) + "Move 1 cherry to branch" + (format "Move %s cherries to branch" len)))))) + 'allow-detached)) + (magit--cherry-move commits + (or (magit-get-current-branch) + (magit-rev-parse "HEAD")) + branch args)) + +;;;###autoload +(defun magit-cherry-spinout (commits branch start-point &optional args) + "Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and stay on that branch. +If a conflict occurs, then you have to fix that and finish the +process manually." + (interactive (magit--cherry-spinoff-read-args "spinout")) + (magit--cherry-move commits (magit-get-current-branch) branch args + start-point)) + +;;;###autoload +(defun magit-cherry-spinoff (commits branch start-point &optional args) + "Move COMMITS from the current branch onto a new BRANCH. +Remove COMMITS from the current branch and checkout BRANCH. +If a conflict occurs, then you have to fix that and finish +the process manually." + (interactive (magit--cherry-spinoff-read-args "spinoff")) + (magit--cherry-move commits (magit-get-current-branch) branch args + start-point t)) + +(defun magit--cherry-move (commits src dst args + &optional start-point checkout-dst) + (let ((current (magit-get-current-branch))) + (unless (magit-branch-p dst) + (let ((magit-process-raise-error t)) + (magit-call-git "branch" dst start-point)) + (when-let ((upstream (magit-get-indirect-upstream-branch start-point))) + (magit-call-git "branch" "--set-upstream-to" upstream dst))) + (unless (equal dst current) + (let ((magit-process-raise-error t)) + (magit-call-git "checkout" dst))) + (if (not src) ; harvest only + (magit--cherry-pick commits args) + (let ((tip (car (last commits))) + (keep (concat (car commits) "^"))) + (magit--cherry-pick commits args) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (cond + ((magit-rev-equal tip src) + (magit-call-git "update-ref" + "-m" (format "reset: moving to %s" keep) + (magit-ref-fullname src) + keep tip) + (if (not checkout-dst) + (magit-run-git "checkout" src) + (magit-refresh))) + (t + (magit-git "checkout" src) + (with-environment-variables + (("GIT_SEQUENCE_EDITOR" + (format "%s -i -ne '/^pick (%s)/ or print'" + magit-perl-executable + (mapconcat #'magit-rev-abbrev commits "|")))) + (magit-run-git-sequencer "rebase" "-i" keep)) + (when checkout-dst + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-run-git "checkout" dst)))))))))))))))) + +(defun magit--cherry-pick (commits args &optional revert) + (let ((command (if revert "revert" "cherry-pick"))) + (when (stringp commits) + (setq commits (if (string-search ".." commits) + (split-string commits "\\.\\.") + (list commits)))) + (magit-run-git-sequencer + (if revert "revert" "cherry-pick") + (let ((merges (seq-filter #'magit-merge-commit-p commits))) + (cond + ((not merges) + (seq-remove (##string-prefix-p "--mainline=" %) args)) + ((cl-set-difference commits merges :test #'equal) + (user-error "Cannot %s merge and non-merge commits at once" + command)) + ((seq-find (##string-prefix-p "--mainline=" %) args) + args) + (t + (cons (format "--mainline=%s" + (read-number "Replay merges relative to parent: ")) + args)))) + commits))) + +(defun magit-cherry-pick-in-progress-p () + ;; .git/sequencer/todo does not exist when there is only one commit left. + (let ((dir (magit-gitdir))) + (or (file-exists-p (expand-file-name "CHERRY_PICK_HEAD" dir)) + ;; And CHERRY_PICK_HEAD does not exist when a conflict happens + ;; while picking a series of commits with --no-commit. + (and-let* ((line (magit-file-line + (expand-file-name "sequencer/todo" dir)))) + (string-prefix-p "pick" line))))) + +;;; Revert + +;;;###autoload (autoload 'magit-revert "magit-sequence" nil t) +(transient-define-prefix magit-revert () + "Revert existing commits, with or without creating new commits." + :man-page "git-revert" + :value '("--edit") + ["Arguments" + :if-not magit-sequencer-in-progress-p + (magit-cherry-pick:--mainline) + ("-e" "Edit commit message" ("-e" "--edit")) + ("-E" "Don't edit commit message" "--no-edit") + ("=s" magit-merge:--strategy) + (magit:--gpg-sign) + (magit:--signoff)] + ["Actions" + :if-not magit-sequencer-in-progress-p + ("V" "Revert commit(s)" magit-revert-and-commit) + ("v" "Revert changes" magit-revert-no-commit)] + ["Actions" + :if magit-sequencer-in-progress-p + ("V" "Continue" magit-sequencer-continue) + ("s" "Skip" magit-sequencer-skip) + ("a" "Abort" magit-sequencer-abort)]) + +(defun magit-revert-read-args (prompt) + (list (or (magit-region-values 'commit) + (magit-read-branch-or-commit prompt)) + (transient-args 'magit-revert))) + +;;;###autoload +(defun magit-revert-and-commit (commit &optional args) + "Revert COMMIT by creating a new commit. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting." + (interactive (magit-revert-read-args "Revert commit")) + (magit--cherry-pick commit args t)) + +;;;###autoload +(defun magit-revert-no-commit (commit &optional args) + "Revert COMMIT by applying it in reverse to the worktree. +Prompt for a commit, defaulting to the commit at point. If +the region selects multiple commits, then revert all of them, +without prompting." + (interactive (magit-revert-read-args "Revert changes")) + (magit--cherry-pick commit (cons "--no-commit" args) t)) + +(defun magit-revert-in-progress-p () + ;; .git/sequencer/todo does not exist when there is only one commit left. + (let ((dir (magit-gitdir))) + (or (file-exists-p (expand-file-name "REVERT_HEAD" dir)) + ;; And REVERT_HEAD does not exist when a conflict happens + ;; while reverting a series of commits with --no-commit. + (and-let* ((line (magit-file-line + (expand-file-name "sequencer/todo" dir)))) + (string-prefix-p "revert" line))))) + +;;; Patch + +;;;###autoload (autoload 'magit-am "magit-sequence" nil t) +(transient-define-prefix magit-am () + "Apply patches received by email." + :man-page "git-am" + :value '("--3way") + ["Arguments" + :if-not magit-am-in-progress-p + ("-3" "Fall back on 3way merge" ("-3" "--3way")) + (magit-apply:-p) + ("-c" "Remove text before scissors line" ("-c" "--scissors")) + ("-k" "Inhibit removal of email cruft" ("-k" "--keep")) + ("-b" "Limit removal of email cruft" "--keep-non-patch") + ("-d" "Use author date as committer date" "--committer-date-is-author-date") + ("-t" "Use current time as author date" "--ignore-date") + (magit:--gpg-sign) + (magit:--signoff)] + ["Apply" + :if-not magit-am-in-progress-p + ("m" "maildir" magit-am-apply-maildir) + ("w" "patches" magit-am-apply-patches) + ("a" "plain patch" magit-patch-apply)] + ["Actions" + :if magit-am-in-progress-p + ("w" "Continue" magit-am-continue) + ("s" "Skip" magit-am-skip) + ("a" "Abort" magit-am-abort)]) + +(defun magit-am-arguments () + (transient-args 'magit-am)) + +(transient-define-argument magit-apply:-p () + :description "Remove leading slashes from paths" + :class 'transient-option + :argument "-p" + :allow-empty t + :reader #'transient-read-number-N+) + +;;;###autoload +(defun magit-am-apply-patches (&optional files args) + "Apply the patches FILES." + (interactive (list (or (magit-region-values 'file) + (list (let ((default (magit-file-at-point))) + (read-file-name + (if default + (format "Apply patch (%s): " default) + "Apply patch: ") + nil default)))) + (magit-am-arguments))) + (magit-run-git-sequencer "am" args "--" + (mapcar (##magit-convert-filename-for-git + (expand-file-name %)) + files))) + +;;;###autoload +(defun magit-am-apply-maildir (&optional maildir args) + "Apply the patches from MAILDIR." + (interactive (list (read-file-name "Apply mbox or Maildir: ") + (magit-am-arguments))) + (magit-run-git-sequencer "am" args (magit-convert-filename-for-git + (expand-file-name maildir)))) + +;;;###autoload +(defun magit-am-continue () + "Resume the current patch applying sequence." + (interactive) + (cond + ((not (magit-am-in-progress-p)) + (user-error "Not applying any patches")) + ((magit-anything-unstaged-p t) + (user-error "Cannot continue due to unstaged changes")) + ((magit-run-git-sequencer "am" "--continue")))) + +;;;###autoload +(defun magit-am-skip () + "Skip the stopped at patch during a patch applying sequence." + (interactive) + (unless (magit-am-in-progress-p) + (user-error "Not applying any patches")) + (magit-run-git-sequencer "am" "--skip")) + +;;;###autoload +(defun magit-am-abort () + "Abort the current patch applying sequence. +This discards all changes made since the sequence started." + (interactive) + (unless (magit-am-in-progress-p) + (user-error "Not applying any patches")) + (magit-run-git "am" "--abort")) + +(defun magit-am-in-progress-p () + (file-exists-p (expand-file-name "rebase-apply/applying" (magit-gitdir)))) + +;;; Rebase + +;;;###autoload (autoload 'magit-rebase "magit-sequence" nil t) +(transient-define-prefix magit-rebase () + "Transplant commits and/or modify existing commits." + :man-page "git-rebase" + :value '("--autostash") + ["Arguments" + :if-not magit-rebase-in-progress-p + ("-k" "Keep empty commits" "--keep-empty") + ("-p" "Preserve merges" ("-p" "--preserve-merges") + :if (##magit-git-version< "2.33.0")) + ("-r" "Rebase merges" ("-r" "--rebase-merges=") + magit-rebase-merges-select-mode) + ("-u" "Update branches" "--update-refs" + :if (##magit-git-version>= "2.38.0")) + (7 magit-merge:--strategy) + (7 magit-merge:--strategy-option) + (7 "=X" magit-diff:--diff-algorithm :argument "-Xdiff-algorithm=") + (7 "-f" "Force rebase" ("-f" "--force-rebase")) + ("-d" "Use author date as committer date" "--committer-date-is-author-date") + ("-t" "Use current time as author date" "--ignore-date") + ("-a" "Autosquash" "--autosquash") + ("-A" "Autostash" "--autostash") + ("-i" "Interactive" ("-i" "--interactive")) + ("-h" "Disable hooks" "--no-verify") + (7 magit-rebase:--exec) + (magit:--gpg-sign) + (magit:--signoff)] + [:if-not magit-rebase-in-progress-p + :description (##format (propertize "Rebase %s onto" 'face 'transient-heading) + (propertize (or (magit-get-current-branch) "HEAD") + 'face 'magit-branch-local)) + ("p" magit-rebase-onto-pushremote) + ("u" magit-rebase-onto-upstream) + ("e" "elsewhere" magit-rebase-branch)] + ["Rebase" + :if-not magit-rebase-in-progress-p + [("i" "interactively" magit-rebase-interactive) + ("s" "a subset" magit-rebase-subset)] + [("m" "to modify a commit" magit-rebase-edit-commit) + ("w" "to reword a commit" magit-rebase-reword-commit) + ("k" "to remove a commit" magit-rebase-remove-commit)] + [("f" "to autosquash" magit-rebase-autosquash) + (6 "t" "to change dates" magit-reshelve-since)]] + ["Actions" + :if magit-rebase-in-progress-p + ("r" "Continue" magit-rebase-continue) + ("s" "Skip" magit-rebase-skip) + ("e" "Edit" magit-rebase-edit) + ("a" "Abort" magit-rebase-abort)]) + +(transient-define-argument magit-rebase:--exec () + :description "Run command after commits" + :class 'transient-option + :shortarg "-x" + :argument "--exec=" + :reader #'read-shell-command) + +(defun magit-rebase-merges-select-mode (&rest _ignore) + (magit-read-char-case nil t + (?n "[n]o-rebase-cousins" "no-rebase-cousins") + (?r "[r]ebase-cousins" "rebase-cousins"))) + +(defun magit-rebase-arguments () + (transient-args 'magit-rebase)) + +(defun magit-git-rebase (target args) + (magit-run-git-sequencer "rebase" args target)) + +;;;###autoload (autoload 'magit-rebase-onto-pushremote "magit-sequence" nil t) +(transient-define-suffix magit-rebase-onto-pushremote (args) + "Rebase the current branch onto its push-remote branch. + +With a prefix argument or when the push-remote is either not +configured or unusable, then let the user first configure the +push-remote." + :if #'magit-get-current-branch + :description #'magit-pull--pushbranch-description + (interactive (list (magit-rebase-arguments))) + (pcase-let ((`(,branch ,remote) + (magit--select-push-remote "rebase onto that"))) + (magit-git-rebase (concat remote "/" branch) args))) + +;;;###autoload (autoload 'magit-rebase-onto-upstream "magit-sequence" nil t) +(transient-define-suffix magit-rebase-onto-upstream (args) + "Rebase the current branch onto its upstream branch. + +With a prefix argument or when the upstream is either not +configured or unusable, then let the user first configure +the upstream." + :if #'magit-get-current-branch + :description #'magit-rebase--upstream-description + (interactive (list (magit-rebase-arguments))) + (let* ((branch (or (magit-get-current-branch) + (user-error "No branch is checked out"))) + (upstream (magit-get-upstream-branch branch))) + (when (or current-prefix-arg (not upstream)) + (setq upstream + (magit-read-upstream-branch + branch (format "Set upstream of %s and rebase onto that" branch))) + (magit-set-upstream-branch branch upstream)) + (magit-git-rebase upstream args))) + +(defun magit-rebase--upstream-description () + (and-let* ((branch (magit-get-current-branch))) + (or (magit-get-upstream-branch branch) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (u (magit--propertize-face "@{upstream}" 'bold))) + (cond + ((magit--unnamed-upstream-p remote merge) + (concat u ", replacing unnamed")) + ((magit--valid-upstream-p remote merge) + (concat u ", replacing non-existent")) + ((or remote merge) + (concat u ", replacing invalid")) + (t + (concat u ", setting that"))))))) + +;;;###autoload +(defun magit-rebase-branch (target args) + "Rebase the current branch onto a branch read in the minibuffer. +All commits that are reachable from `HEAD' but not from the +selected branch TARGET are being rebased." + (interactive (list (magit-read-other-branch-or-commit "Rebase onto") + (magit-rebase-arguments))) + (message "Rebasing...") + (magit-git-rebase target args) + (message "Rebasing...done")) + +;;;###autoload +(defun magit-rebase-subset (newbase start args) + "Rebase a subset of the current branch's history onto a new base. +Rebase commits from START to `HEAD' onto NEWBASE. +START has to be selected from a list of recent commits." + (interactive (list (magit-read-other-branch-or-commit + "Rebase subset onto" nil + (magit-get-upstream-branch)) + nil + (magit-rebase-arguments))) + (if start + (progn (message "Rebasing...") + (magit-run-git-sequencer "rebase" "--onto" newbase start args) + (message "Rebasing...done")) + (magit-log-select + `(lambda (commit) + (magit-rebase-subset ,newbase (concat commit "^") (list ,@args))) + (concat "Type %p on a commit to rebase it " + "and commits above it onto " newbase ",")))) + +(defvar magit-rebase-interactive-include-selected t) + +(defun magit-rebase-interactive-1 + (commit args message &optional editor delay-edit-confirm noassert confirm) + (declare (indent 2)) + (when commit + (unless (magit-rev-ancestor-p commit "HEAD") + (user-error "%s isn't an ancestor of HEAD" commit)) + (if (magit-commit-parents commit) + (when (or (not (eq this-command 'magit-rebase-interactive)) + magit-rebase-interactive-include-selected) + (setq commit (concat commit "^"))) + (setq args (cons "--root" args)))) + (when (and commit (not noassert)) + (setq commit (magit-rebase-interactive-assert + commit delay-edit-confirm + (seq-some (##string-prefix-p "--rebase-merges" %) args)))) + (if (and commit (not confirm)) + (let ((process-environment process-environment)) + (when editor + (push (concat "GIT_SEQUENCE_EDITOR=" + (if (functionp editor) + (funcall editor commit) + editor)) + process-environment)) + (magit-run-git-sequencer "rebase" "-i" args + (and (not (member "--root" args)) commit))) + (magit-log-select + `(lambda (commit) + ;; In some cases (currently just magit-rebase-remove-commit), "-c + ;; commentChar=#" is added to the global arguments for git. Ensure + ;; that the same happens when we chose the commit via + ;; magit-log-select, below. + (let ((magit-git-global-arguments (list ,@magit-git-global-arguments))) + (magit-rebase-interactive-1 commit (list ,@args) + ,message ,editor ,delay-edit-confirm ,noassert))) + message))) + +(defvar magit--rebase-published-symbol nil) +(defvar magit--rebase-public-edit-confirmed nil) + +(defun magit-rebase-interactive-assert + (since &optional delay-edit-confirm rebase-merges) + (let* ((commit (magit-rebase--target-commit since)) + (branches (magit-list-publishing-branches commit))) + (setq magit--rebase-public-edit-confirmed + (delete (magit-toplevel) magit--rebase-public-edit-confirmed)) + (when (and branches + (or (not delay-edit-confirm) + ;; The user might have stopped at a published commit + ;; merely to add new commits *after* it. Try not to + ;; ask users whether they really want to edit public + ;; commits, when they don't actually intend to do so. + (not (seq-every-p (##magit-rev-equal % commit) branches)))) + (let ((m1 "Some of these commits have already been published to ") + (m2 ".\nDo you really want to modify them")) + (magit-confirm (or magit--rebase-published-symbol 'rebase-published) + (concat m1 "%s" m2) + (concat m1 "%d public branches" m2) + nil branches)) + (push (magit-toplevel) magit--rebase-public-edit-confirmed))) + (if (and (magit-git-lines "rev-list" "--merges" (concat since "..HEAD")) + (not rebase-merges)) + (magit-read-char-case "Proceed despite merge in rebase range? " nil + (?c "[c]ontinue" since) + (?s "[s]elect other" nil) + (?a "[a]bort" (user-error "Quit"))) + since)) + +(defun magit-rebase--target-commit (since) + (if (string-suffix-p "^" since) + ;; If SINCE is "REV^", then the user selected + ;; "REV", which is the first commit that will + ;; be replaced. (from^..to] <=> [from..to] + (substring since 0 -1) + ;; The "--root" argument is being used. + since)) + +;;;###autoload +(defun magit-rebase-interactive (commit args) + "Start an interactive rebase sequence." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to rebase it and all commits above it," + nil t)) + +;;;###autoload +(defun magit-rebase-autosquash (select args) + "Combine squash and fixup commits with their intended targets. +By default only squash into commits that are not reachable from +the upstream branch. If no upstream is configured or with a prefix +argument, prompt for the first commit to potentially squash into." + (interactive (list current-prefix-arg + (magit-rebase-arguments))) + (magit-rebase-interactive-1 + (and-let* (((not select)) + (upstream (magit-get-upstream-branch))) + (magit-git-string "merge-base" upstream "HEAD")) + (nconc (list "--autosquash" "--keep-empty") args) + "Type %p on a commit to squash into it and then rebase as necessary," + "true" nil t)) + +;;;###autoload +(defun magit-rebase-edit-commit (commit args) + "Edit a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to edit it," + (apply-partially #'magit-rebase--perl-editor 'edit) + t)) + +;;;###autoload +(defun magit-rebase-reword-commit (commit args) + "Reword a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to reword its message," + (apply-partially #'magit-rebase--perl-editor 'reword))) + +;;;###autoload +(defun magit-rebase-remove-commit (commit args) + "Remove a single older commit using rebase." + (interactive (list (magit-commit-at-point) + (magit-rebase-arguments))) + ;; magit-rebase--perl-editor assumes that the comment character is "#". + (let ((magit-git-global-arguments + (nconc (list "-c" "core.commentChar=#") + magit-git-global-arguments))) + (magit-rebase-interactive-1 commit args + "Type %p on a commit to remove it," + (apply-partially #'magit-rebase--perl-editor 'remove) + nil nil t))) + +(defun magit-rebase--perl-editor (action since) + (let ((commit (magit-rev-abbrev (magit-rebase--target-commit since)))) + (format "%s -i -p -e '++$x if not $x and s/^pick %s/%s %s/'" + magit-perl-executable + commit + (cl-case action + (edit "edit") + (remove "noop\n# pick") + (reword "reword") + (t (error "Unknown action: %s" action))) + commit))) + +;;;###autoload +(defun magit-rebase-continue (&optional noedit) + "Restart the current rebasing operation. +In some cases this pops up a commit message buffer for you do +edit. With a prefix argument the old message is reused as-is." + (interactive "P") + (if (magit-rebase-in-progress-p) + (if (magit-anything-unstaged-p t) + (user-error "Cannot continue rebase with unstaged changes") + (let ((dir (magit-gitdir))) + (when (and (magit-anything-staged-p) + (file-exists-p (expand-file-name "rebase-merge" dir)) + (not (member (magit-toplevel) + magit--rebase-public-edit-confirmed))) + (magit-commit-amend-assert + (magit-file-line + (expand-file-name "rebase-merge/orig-head" dir))))) + (if noedit + (with-environment-variables (("GIT_EDITOR" "true")) + (magit-run-git-async (magit--rebase-resume-command) "--continue") + (set-process-sentinel magit-this-process + #'magit-sequencer-process-sentinel) + magit-this-process) + (magit-run-git-sequencer (magit--rebase-resume-command) "--continue"))) + (user-error "No rebase in progress"))) + +;;;###autoload +(defun magit-rebase-skip () + "Skip the current commit and restart the current rebase operation." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-run-git-sequencer (magit--rebase-resume-command) "--skip")) + +;;;###autoload +(defun magit-rebase-edit () + "Edit the todo list of the current rebase operation." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-run-git-sequencer "rebase" "--edit-todo")) + +;;;###autoload +(defun magit-rebase-abort () + "Abort the current rebase operation, restoring the original branch." + (interactive) + (unless (magit-rebase-in-progress-p) + (user-error "No rebase in progress")) + (magit-confirm 'abort-rebase "Abort this rebase") + (magit-run-git (magit--rebase-resume-command) "--abort")) + +(defun magit-rebase-in-progress-p () + "Return t if a rebase is in progress." + (let ((dir (magit-gitdir))) + (or (file-exists-p (expand-file-name "rebase-merge" dir)) + (file-exists-p (expand-file-name "rebase-apply/onto" dir))))) + +(defun magit--rebase-resume-command () + (if (file-exists-p (expand-file-name "rebase-recursive" (magit-gitdir))) + "rbr" + "rebase")) + +(defun magit-rebase--get-state-lines (file) + (and (magit-rebase-in-progress-p) + (let ((dir (magit-gitdir))) + (magit-file-line + (expand-file-name + (concat (if (file-directory-p (expand-file-name "rebase-merge" dir)) + "rebase-merge/" + "rebase-apply/") + file) + dir))))) + +;;; Sections + +(defun magit-insert-sequencer-sequence () + "Insert section for the on-going cherry-pick or revert sequence. +If no such sequence is in progress, do nothing." + (let ((picking (magit-cherry-pick-in-progress-p))) + (when (or picking (magit-revert-in-progress-p)) + (let ((dir (magit-gitdir))) + (magit-insert-section (sequence) + (magit-insert-heading (if picking "Cherry Picking" "Reverting")) + (when-let ((lines (cdr (magit-file-lines + (expand-file-name "sequencer/todo" dir))))) + (dolist (line (nreverse lines)) + (when (string-match + "^\\(pick\\|revert\\) \\([^ ]+\\) \\(.*\\)$" line) + (magit-bind-match-strings (cmd hash msg) line + (magit-insert-section (commit hash) + (insert (propertize cmd 'font-lock-face 'magit-sequence-pick) + " " (propertize hash 'font-lock-face 'magit-hash) + " " msg "\n")))))) + (magit-sequence-insert-sequence + (magit-file-line + (expand-file-name (if picking "CHERRY_PICK_HEAD" "REVERT_HEAD") + dir)) + (magit-file-line (expand-file-name "sequencer/head" dir))) + (insert "\n")))))) + +(defun magit-insert-am-sequence () + "Insert section for the on-going patch applying sequence. +If no such sequence is in progress, do nothing." + (when (magit-am-in-progress-p) + (magit-insert-section (rebase-sequence) + (magit-insert-heading "Applying patches") + (let* ((patches (nreverse (magit-rebase-patches))) + (dir (expand-file-name "rebase-apply" (magit-gitdir))) + (i (string-to-number + (magit-file-line (expand-file-name "last" dir)))) + (cur (string-to-number + (magit-file-line (expand-file-name "next" dir)))) + patch commit) + (while (and patches (>= i cur)) + (setq patch (pop patches)) + (setq commit (magit-commit-p + (cadr (split-string (magit-file-line patch))))) + (cond ((and commit (= i cur)) + (magit-sequence-insert-commit + "stop" commit 'magit-sequence-stop)) + ((= i cur) + (magit-sequence-insert-am-patch + "stop" patch 'magit-sequence-stop)) + (commit + (magit-sequence-insert-commit + "pick" commit 'magit-sequence-pick)) + (t + (magit-sequence-insert-am-patch + "pick" patch 'magit-sequence-pick))) + (cl-decf i))) + (magit-sequence-insert-sequence nil "ORIG_HEAD") + (insert ?\n)))) + +(defun magit-sequence-insert-am-patch (type patch face) + (magit-insert-section (file patch) + (let ((title + (with-temp-buffer + (insert-file-contents patch nil nil 4096) + (unless (re-search-forward "^Subject: " nil t) + (goto-char (point-min))) + (buffer-substring (point) (line-end-position))))) + (insert (propertize type 'font-lock-face face) + ?\s (propertize (file-name-nondirectory patch) + 'font-lock-face 'magit-hash) + ?\s title + ?\n)))) + +(defun magit-insert-rebase-sequence () + "Insert section for the on-going rebase sequence. +If no such sequence is in progress, do nothing." + (when (magit-rebase-in-progress-p) + (let* ((gitdir (magit-gitdir)) + (mergep (file-directory-p (expand-file-name "rebase-merge" gitdir))) + (dir (if mergep "rebase-merge/" "rebase-apply/")) + (name (thread-first (concat dir "head-name") + (expand-file-name gitdir) + magit-file-line)) + (onto (thread-first (concat dir "onto") + (expand-file-name gitdir) + magit-file-line)) + (onto (or (magit-rev-name onto name) + (magit-rev-name onto "refs/heads/*") onto)) + (name (or (magit-rev-name name "refs/heads/*") name))) + (magit-insert-section (rebase-sequence) + (magit-insert-heading (format "Rebasing %s onto %s" name onto)) + (if mergep + (magit-rebase-insert-merge-sequence onto) + (magit-rebase-insert-apply-sequence onto)) + (insert ?\n))))) + +(defun magit-rebase--todo () + "Return `git-rebase-action' instances for remaining rebase actions. +These are ordered in that the same way they'll be sorted in the +status buffer (i.e., the reverse of how they will be applied)." + (let ((comment-start (or (magit-get "core.commentChar") "#")) + (commits ()) + (actions ())) + (with-temp-buffer + (insert-file-contents + (expand-file-name "rebase-merge/git-rebase-todo" (magit-gitdir))) + (while (not (eobp)) + (when-let ((obj (git-rebase-current-line t))) + (push obj actions) + (when (memq (oref obj action-type) '(commit merge)) + (push obj commits))) + (forward-line))) + (let ((abbrevs + (and commits + (magit-git-lines + "log" "--no-walk=unsorted" "--format=%h" + (mapcar (lambda (obj) + (if (eq (oref obj action-type) 'merge) + (let ((options (oref obj action-options))) + (and (string-match "-[cC] \\([^ ]+\\)" options) + (match-string 1 options))) + (oref obj target))) + commits))))) + (cl-assert (equal (length commits) (length abbrevs))) + (while-let ((obj (pop commits)) + (val (pop abbrevs))) + (oset obj abbrev val))) + actions)) + +(defun magit-rebase-insert-merge-sequence (onto) + (dolist (obj (magit-rebase--todo)) + (with-slots (action-type action action-options target abbrev trailer) obj + (pcase action-type + ((or 'commit (and 'merge (guard abbrev))) + (magit-sequence-insert-commit action target 'magit-sequence-pick + abbrev trailer)) + ((guard action) (magit-sequence-insert-step action target))))) + (let ((dir (magit-gitdir))) + (magit-sequence-insert-sequence + (magit-file-line (expand-file-name "rebase-merge/stopped-sha" dir)) + onto + (and-let* ((lines (magit-file-lines + (expand-file-name "rebase-merge/done" dir)))) + (cadr (split-string (car (last lines)))))))) + +(defun magit-rebase-insert-apply-sequence (onto) + (let* ((dir (magit-gitdir)) + (rewritten + (mapcar (##car (split-string %)) + (magit-file-lines + (expand-file-name "rebase-apply/rewritten" dir)))) + (stop (magit-file-line + (expand-file-name "rebase-apply/original-commit" dir)))) + (dolist (patch (nreverse (cdr (magit-rebase-patches)))) + (let ((hash (cadr (split-string (magit-file-line patch))))) + (unless (or (member hash rewritten) + (equal hash stop)) + (magit-sequence-insert-commit "pick" hash 'magit-sequence-pick)))) + (magit-sequence-insert-sequence + (magit-file-line (expand-file-name "rebase-apply/original-commit" dir)) + onto))) + +(defun magit-rebase-patches () + (directory-files (expand-file-name "rebase-apply" (magit-gitdir)) + t "\\`[0-9]\\{4\\}\\'")) + +(defun magit-sequence-insert-sequence (stop onto &optional orig) + (let ((head (magit-rev-parse "HEAD")) done) + (setq onto (if onto (magit-rev-parse onto) head)) + (setq done (mapcar (##split-string % "\0") + (magit-git-lines "log" "--format=%H%x00%h%x00%s" + (concat onto "..HEAD")))) + (when (and stop (not (assoc (magit-rev-parse stop) done))) + (let ((id (magit-patch-id stop))) + (if-let ((matched (car (assoc (##equal (magit-patch-id %) id) done)))) + (setq stop matched) + (cond + ((assoc (##magit-rev-equal % stop) done) + ;; The commit's testament has been executed. + (magit-sequence-insert-commit "void" stop 'magit-sequence-drop)) + ;; The faith of the commit is still undecided... + ((magit-anything-unmerged-p) + ;; ...and time travel isn't for the faint of heart. + (magit-sequence-insert-commit "join" stop 'magit-sequence-part)) + ((magit-anything-modified-p t) + ;; ...and the dust hasn't settled yet... + (magit-sequence-insert-commit + (let* ((magit--refresh-cache nil) + (staged (magit-commit-tree "oO" nil "HEAD")) + (unstaged (magit-commit-worktree "oO" "--reset"))) + (cond + ;; ...but we could end up at the same tree just by committing. + ((or (magit-rev-equal staged stop) + (magit-rev-equal unstaged stop)) + "goal") + ;; ...but the changes are still there, untainted. + ((or (equal (magit-patch-id staged) id) + (equal (magit-patch-id unstaged) id)) + "same") + ;; ...and some changes are gone and/or others were added. + (t "work"))) + stop 'magit-sequence-part)) + ;; The commit is definitely gone... + ((assoc (##magit-rev-equal % stop) done) + ;; ...but all of its changes are still in effect. + (magit-sequence-insert-commit "poof" stop 'magit-sequence-drop)) + (t + ;; ...and some changes are gone and/or other changes were added. + (magit-sequence-insert-commit "gone" stop 'magit-sequence-drop))) + (setq stop nil)))) + (pcase-dolist (`(,rev ,abbrev ,msg) done) + (apply #'magit-sequence-insert-commit + (cond ((equal rev stop) + ;; ...but its reincarnation lives on. + ;; Or it didn't die in the first place. + (list (if (and (equal rev head) + (equal (magit-patch-id rev) + (magit-patch-id orig))) + "stop" ; We haven't done anything yet. + "like") ; There are new commits. + rev (if (equal rev head) + 'magit-sequence-head + 'magit-sequence-stop) + abbrev msg)) + ((equal rev head) + (list "done" rev 'magit-sequence-head abbrev msg)) + (t + (list "done" rev 'magit-sequence-done abbrev msg))))) + (magit-sequence-insert-commit "onto" onto + (if (equal onto head) + 'magit-sequence-head + 'magit-sequence-onto)))) + +(defun magit-sequence-insert-commit (type hash face &optional abbrev msg) + (magit-insert-section (commit hash) + (magit-insert-heading + (propertize type 'font-lock-face face) " " + (if abbrev + (concat (propertize abbrev 'face 'magit-hash) " " msg "\n") + (concat (magit-format-rev-summary hash) "\n"))))) + +(defun magit-sequence-insert-step (type target) + (magit-insert-section (rebase-step (cons type target)) + (magit-insert-heading + (propertize type 'font-lock-face 'magit-sequence-pick) + (and target + (concat "\s" + (propertize target 'font-lock-face 'git-rebase-label)))))) + +;;; _ +(provide 'magit-sequence) +;;; magit-sequence.el ends here blob - /dev/null blob + 1df657a784b119b4ccd36509d225e44d59d8c181 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-sparse-checkout.el @@ -0,0 +1,158 @@ +;;; magit-sparse-checkout.el --- Sparse checkout support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Kyle Meyer +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library provides an interface to the `git sparse-checkout' +;; command. It's been possible to define sparse checkouts since Git +;; v1.7.0 by adding patterns to $GIT_DIR/info/sparse-checkout and +;; calling `git read-tree -mu HEAD' to update the index and working +;; tree. However, Git v2.25 introduced the `git sparse-checkout' +;; command along with "cone mode", which restricts the possible +;; patterns to directories to provide better performance. +;; +;; The goal of this library is to support the `git sparse-checkout' +;; command operating in cone mode. + +;;; Code: + +(require 'magit) + +;;; Utilities + +(defun magit-sparse-checkout-enabled-p () + "Return non-nil if working tree is a sparse checkout." + (magit-get-boolean "core.sparsecheckout")) + +(defun magit-sparse-checkout--auto-enable () + (if (magit-sparse-checkout-enabled-p) + (unless (magit-get-boolean "core.sparsecheckoutcone") + (user-error + "Magit's sparse checkout functionality requires cone mode")) + ;; Note: Don't use `magit-sparse-checkout-enable' because it's + ;; asynchronous. + (magit-run-git "sparse-checkout" "init" "--cone"))) + +(defun magit-sparse-checkout-directories () + "Return directories that are recursively included in the sparse checkout. +See the `git sparse-checkout' manpage for details about +\"recursive\" versus \"parent\" directories in cone mode." + (and (magit-get-boolean "core.sparsecheckoutcone") + (mapcar #'file-name-as-directory + (magit-git-lines "sparse-checkout" "list")))) + +;;; Commands + +;;;###autoload (autoload 'magit-sparse-checkout "magit-sparse-checkout" nil t) +(transient-define-prefix magit-sparse-checkout () + "Create and manage sparse checkouts." + :man-page "git-sparse-checkout" + ["Arguments for enabling" + :if-not magit-sparse-checkout-enabled-p + ("-i" "Use sparse index" "--sparse-index")] + ["Actions" + [:if-not magit-sparse-checkout-enabled-p + ("e" "Enable sparse checkout" magit-sparse-checkout-enable)] + [:if magit-sparse-checkout-enabled-p + ("d" "Disable sparse checkout" magit-sparse-checkout-disable) + ("r" "Reapply rules" magit-sparse-checkout-reapply)] + [("s" "Set directories" magit-sparse-checkout-set) + ("a" "Add directories" magit-sparse-checkout-add)]]) + +;;;###autoload +(defun magit-sparse-checkout-enable (&optional args) + "Convert the working tree to a sparse checkout." + (interactive (list (transient-args 'magit-sparse-checkout))) + (magit-run-git-async "sparse-checkout" "init" "--cone" args)) + +;;;###autoload +(defun magit-sparse-checkout-set (directories) + "Restrict working tree to DIRECTORIES. +To extend rather than override the currently configured +directories, call `magit-sparse-checkout-add' instead." + (interactive + (list (magit-completing-read-multiple + "Include these directories: " + ;; Note: Given that the appeal of sparse checkouts is + ;; dealing with very large trees, listing all subdirectories + ;; may need to be reconsidered. + (magit-revision-directories "HEAD")))) + (magit-sparse-checkout--auto-enable) + (magit-run-git-async "sparse-checkout" "set" directories)) + +;;;###autoload +(defun magit-sparse-checkout-add (directories) + "Add DIRECTORIES to the working tree. +To override rather than extend the currently configured +directories, call `magit-sparse-checkout-set' instead." + (interactive + (list (magit-completing-read-multiple + "Add these directories: " + ;; Same performance note as in `magit-sparse-checkout-set', + ;; but even more so given the additional processing. + (seq-remove + (let ((re (concat + "\\`" + (regexp-opt (magit-sparse-checkout-directories))))) + (##string-match-p re %)) + (magit-revision-directories "HEAD"))))) + (magit-sparse-checkout--auto-enable) + (magit-run-git-async "sparse-checkout" "add" directories)) + +;;;###autoload +(defun magit-sparse-checkout-reapply () + "Reapply the sparse checkout rules to the working tree. +Some operations such as merging or rebasing may need to check out +files that aren't included in the sparse checkout. Call this +command to reset to the sparse checkout state." + (interactive) + (magit-run-git-async "sparse-checkout" "reapply")) + +;;;###autoload +(defun magit-sparse-checkout-disable () + "Convert sparse checkout to full checkout. +Note that disabling the sparse checkout does not clear the +configured directories. Call `magit-sparse-checkout-enable' to +restore the previous sparse checkout." + (interactive) + (magit-run-git-async "sparse-checkout" "disable")) + +;;; Miscellaneous + +(defun magit-sparse-checkout-insert-header () + "Insert header line with sparse checkout information. +This header is not inserted by default. To enable it, add it to +`magit-status-headers-hook'." + (when (magit-sparse-checkout-enabled-p) + (insert (propertize (format "%-10s" "Sparse! ") + 'font-lock-face 'magit-section-heading)) + (insert + (let ((dirs (magit-sparse-checkout-directories))) + (pcase (length dirs) + (0 "top-level directory") + (1 (car dirs)) + (n (format "%d directories" n))))) + (insert ?\n))) + +;;; _ +(provide 'magit-sparse-checkout) +;;; magit-sparse-checkout.el ends here blob - /dev/null blob + 1ca279db7addcf148fda80a6a25e8868163b344f (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-stash.el @@ -0,0 +1,684 @@ +;;; magit-stash.el --- Stash support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Support for Git stashes. + +;;; Code: + +(require 'magit) +(require 'magit-reflog) +(require 'magit-sequence) + +;;; Options + +(defgroup magit-stash nil + "List stashes and show stash diffs." + :group 'magit-modes) + +;;;; Diff options + +(defcustom magit-stash-sections-hook + (list #'magit-insert-stash-notes + #'magit-insert-stash-worktree + #'magit-insert-stash-index + #'magit-insert-stash-untracked) + "Hook run to insert sections into stash diff buffers." + :package-version '(magit . "2.1.0") + :group 'magit-stash + :type 'hook) + +;;;; Log options + +(defcustom magit-stashes-margin + (list (nth 0 magit-log-margin) + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-stashes-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-stash + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-stashes-mode)) + +;;;; Variables + +(defvar magit-stash-read-message-function #'magit-stash-read-message + "Function used to read the message when creating a stash.") + +;;; Commands + +;;;###autoload (autoload 'magit-stash "magit-stash" nil t) +(transient-define-prefix magit-stash () + "Stash uncommitted changes." + :man-page "git-stash" + ["Arguments" + ("-u" "Also save untracked files" ("-u" "--include-untracked")) + ("-a" "Also save untracked and ignored files" ("-a" "--all"))] + [["Stash" + ("z" "both" magit-stash-both) + ("i" "index" magit-stash-index) + ("w" "worktree" magit-stash-worktree) + ("x" "keeping index" magit-stash-keep-index) + ("P" "push" magit-stash-push :level 5)] + ["Snapshot" + ("Z" "both" magit-snapshot-both) + ("I" "index" magit-snapshot-index) + ("W" "worktree" magit-snapshot-worktree) + ("r" "to wip ref" magit-wip-commit)] + ["Use" + ("a" "Apply" magit-stash-apply) + ("p" "Pop" magit-stash-pop) + ("k" "Drop" magit-stash-drop)] + ["Inspect" + ("l" "List" magit-stash-list) + ("v" "Show" magit-stash-show)] + ["Transform" + ("b" "Branch" magit-stash-branch) + ("B" "Branch here" magit-stash-branch-here) + ("f" "Format patch" magit-stash-format-patch)]]) + +(defun magit-stash-arguments () + (transient-args 'magit-stash)) + +;;;###autoload +(defun magit-stash-both (message &optional include-untracked) + "Create a stash of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive + (progn (when (and (magit-merge-in-progress-p) + (not (magit-y-or-n-p "\ +Stashing and resetting during a merge conflict. \ +Applying the resulting stash won't restore the merge state. \ +Proceed anyway? "))) + (user-error "Abort")) + (magit-stash-read-args))) + (magit-stash-save message t t include-untracked t)) + +;;;###autoload +(defun magit-stash-index (message) + "Create a stash of the index only. +Unstaged and untracked changes are not stashed. The stashed +changes are applied in reverse to both the index and the +worktree. This command can fail when the worktree is not clean. +Applying the resulting stash has the inverse effect." + (interactive (list (funcall magit-stash-read-message-function))) + (magit-stash-save message t nil nil t 'worktree)) + +;;;###autoload +(defun magit-stash-worktree (message &optional include-untracked) + "Create a stash of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-stash-read-args)) + (magit-stash-save message nil t include-untracked t 'index)) + +;;;###autoload +(defun magit-stash-keep-index (message &optional include-untracked) + "Create a stash of the index and working tree, keeping index intact. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-stash-read-args)) + (magit-stash-save message t t include-untracked t 'index)) + +(defun magit-stash-read-args () + (list (funcall magit-stash-read-message-function) + (magit-stash-read-untracked))) + +(defun magit-stash-read-message () + "Read a message from the minibuffer, to be used for a stash. + +The message that Git would have picked, is available as the +default (used when the user enters the empty string) and as +the first future history element. The second future history +element is just \"On BRANCH: \". Future history elements can +be accessed using \\\\[next-history-element])." + (let ((branch (or (magit-get-current-branch) "(no branch)")) + (ellipsis (magit--ellipsis))) + (read-string (format "Stash message (default: On%s:%s): " ellipsis ellipsis) + nil nil + (list (format "On %s: %s" branch (magit-rev-format "%h %s")) + (format "On %s: " branch))))) + +(defun magit-stash-read-message-traditional () + "Read a message from the minibuffer, to be used for a stash. + +If the user confirms the initial-input unmodified, then the +abbreviated commit hash and commit summary are appended. +The resulting message is what Git would have used." + (let* ((default (format "On %s: " + (or (magit-get-current-branch) "(no branch)"))) + (input (magit-read-string "Stash message" default))) + (if (equal input default) + (concat default (magit-rev-format "%h %s")) + input))) + +(defun magit-stash-read-untracked () + (let ((prefix (prefix-numeric-value current-prefix-arg)) + (args (magit-stash-arguments))) + (cond ((or (= prefix 16) (member "--all" args)) 'all) + ((or (= prefix 4) (member "--include-untracked" args)) t)))) + +;;;###autoload +(defun magit-snapshot-both (&optional include-untracked) + "Create a snapshot of the index and working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-snapshot-read-args)) + (magit-snapshot-save t t include-untracked t)) + +;;;###autoload +(defun magit-snapshot-index () + "Create a snapshot of the index only. +Unstaged and untracked changes are not stashed." + (interactive) + (magit-snapshot-save t nil nil t)) + +;;;###autoload +(defun magit-snapshot-worktree (&optional include-untracked) + "Create a snapshot of unstaged changes in the working tree. +Untracked files are included according to infix arguments. +One prefix argument is equivalent to `--include-untracked' +while two prefix arguments are equivalent to `--all'." + (interactive (magit-snapshot-read-args)) + (magit-snapshot-save nil t include-untracked t)) + +(defun magit-snapshot-read-args () + (list (magit-stash-read-untracked))) + +(defun magit-snapshot-save (index worktree untracked &optional refresh) + (magit-stash-save (concat "WIP on " (magit-stash-summary)) + index worktree untracked refresh t)) + +;;;###autoload (autoload 'magit-stash-push "magit-stash" nil t) +(transient-define-prefix magit-stash-push (&optional transient args) + "Create stash using \"git stash push\". + +This differs from Magit's other stashing commands, which don't +use \"git stash\" and are generally more flexible but don't allow +specifying a list of files to be stashed." + :man-page "git-stash" + ["Arguments" + (magit:-- :reader (lambda (prompt initial-input history) + (magit-read-files prompt initial-input history + #'magit-modified-files))) + ("-u" "Also save untracked files" ("-u" "--include-untracked")) + ("-a" "Also save untracked and ignored files" ("-a" "--all")) + ("-k" "Keep index" ("-k" "--keep-index")) + ("-K" "Don't keep index" "--no-keep-index")] + ["Actions" + ("P" "push" magit-stash-push)] + (interactive (if (eq transient-current-command 'magit-stash-push) + (list nil (transient-args 'magit-stash-push)) + (list t))) + (if transient + (transient-setup 'magit-stash-push) + (magit-run-git "stash" "push" + (seq-filter #'atom args) + (assoc "--" args)))) + +;;;###autoload +(defun magit-stash-apply (stash) + "Apply a stash to the working tree. + +When using a Git release before v2.38.0, simply run \"git stash +apply\" or with a prefix argument \"git stash apply --index\". + +When using Git v2.38.0 or later, behave more intelligently: + +First try \"git stash apply --index\", which tries to preserve the +index stored in the stash, if any. This may fail because applying +the stash could result in conflicts and those have to be stored in +the index, making it impossible to also store the stash's index +there. + +If \"git stash\" fails, then potentially fall back to using \"git +apply\". If the stash does not touch any unstaged files, then pass +\"--3way\" to that command. Otherwise ask the user whether to use +that argument or \"--reject\". Customize `magit-no-confirm' if you +want to fall back to using \"--3way\", without being prompted." + (interactive (list (magit-read-stash "Apply stash"))) + (magit-stash--apply "apply" stash)) + +;;;###autoload +(defun magit-stash-pop (stash) + "Apply a stash to the working tree, on success remove it from stash list. + +When using a Git release before v2.38.0, simply run \"git stash +pop\" or with a prefix argument \"git stash pop --index\". + +When using Git v2.38.0 or later, behave more intelligently: + +First try \"git stash apply --index\", which tries to preserve the +index stored in the stash, if any. This may fail because applying +the stash could result in conflicts and those have to be stored in +the index, making it impossible to also store the stash's index +there. + +If \"git stash\" fails, then potentially fall back to using \"git +apply\". If the stash does not touch any unstaged files, then pass +\"--3way\" to that command. Otherwise ask the user whether to use +that argument or \"--reject\". Customize `magit-no-confirm' if you +want to fall back to using \"--3way\", without being prompted." + (interactive (list (magit-read-stash "Pop stash"))) + (magit-stash--apply "pop" stash)) + +(defun magit-stash--apply (action stash) + (if (magit-git-version< "2.38.0") + (magit-run-git "stash" action stash (and current-prefix-arg "--index")) + (magit-stash--apply-1 action stash) + (magit-refresh))) + +(defun magit-stash--apply-1 (action stash) + (or + (magit--run-git-stash action "--index" stash) + ;; The stash's index could not be applied, so always keep the stash. + (magit--run-git-stash "apply" stash) + (let* ((range (format "%s^..%s" stash stash)) + (stashed (magit-git-items "diff" "-z" "--name-only" range "--")) + (conflicts (cl-sort (cl-union (magit-unstaged-files t stashed) + (magit-untracked-files t stashed) + :test #'equal) + #'string<)) + (arg (if (or (not conflicts) + (memq 'stash-apply-3way magit-no-confirm)) + "--3way" + (magit-read-char-case + (concat + "Could not apply stash because of unstaged changes.\n\n" + "To do a tree-way merge, these files have to be staged\n" + (mapconcat (##format " %s" %) conflicts "\n") + "\n") + nil + (?s (format + "\n[s] stage file%s and apply with \"git apply --3way\"" + (if (length> conflicts 1) "s" "")) + "--3way") + (?r "\n[r] apply with \"git apply --reject\"" "--reject") + (?c "\n[c] cancel" nil))))) + (when arg + (when (and (equal arg "--3way") conflicts) + (magit-stage-1 nil conflicts)) + (with-temp-buffer + (magit-git-insert "diff" range) + (magit-run-git-with-input "apply" arg "-")))))) + +(defun magit--run-git-stash (&rest args) + (magit--with-temp-process-buffer + (let ((exit (save-excursion + (with-environment-variables (("LC_ALL" "en_US.utf8")) + (magit-process-git t "stash" args)))) + (buffer (current-buffer)) + (failed (looking-at "\\`error: "))) + (with-current-buffer (magit-process-buffer t) + (magit-process-finish-section + (magit-process-insert-section default-directory magit-git-executable + (magit-process-git-arguments args) + exit buffer) + exit)) + (pcase (list exit failed) + (`(0 ,_) t) ; no conflict + (`(1 nil) t) ; successfully installed conflict + (_ nil))))) ; could not install conflict, or genuine error + +;;;###autoload +(defun magit-stash-drop (stash) + "Remove a stash from the stash list. +When the region is active offer to drop all contained stashes." + (interactive + (list (if-let ((values (magit-region-values 'stash))) + (magit-confirm 'drop-stashes nil "Drop %d stashes" nil values) + (magit-read-stash "Drop stash")))) + (dolist (stash (if (listp stash) + (nreverse (prog1 stash (setq stash (car stash)))) + (list stash))) + (message "Deleted refs/%s (was %s)" stash + (magit-rev-parse "--short" stash)) + (magit-call-git "rev-parse" stash) + (magit-call-git "stash" "drop" stash)) + (magit-refresh)) + +;;;###autoload +(defun magit-stash-clear (ref) + "Remove all stashes saved in REF's reflog by deleting REF." + (interactive (let ((ref (or (magit-section-value-if 'stashes) "refs/stash"))) + (magit-confirm t (list "Drop all stashes in %s" ref)) + (list ref))) + (magit-run-git "update-ref" "-d" ref)) + +;;;###autoload +(defun magit-stash-branch (stash branch) + "Create and checkout a new BRANCH from an existing STASH. +The new branch starts at the commit that was current when the +stash was created. If the stash applies cleanly, then drop it." + (interactive (list (magit-read-stash "Branch stash") + (magit-read-string-ns "Branch name"))) + (magit-run-git "stash" "branch" branch stash)) + +;;;###autoload +(defun magit-stash-branch-here (stash branch) + "Create and checkout a new BRANCH from an existing STASH. +Use the current branch or `HEAD' as the starting-point of BRANCH. +Then apply STASH, dropping it if it applies cleanly." + (interactive (list (magit-read-stash "Branch stash") + (magit-read-string-ns "Branch name"))) + (let ((start-point (or (magit-get-current-branch) "HEAD"))) + (magit-call-git "checkout" "-b" branch start-point) + (magit-branch-maybe-adjust-upstream branch start-point)) + (magit-stash-apply stash)) + +;;;###autoload +(defun magit-stash-format-patch (stash) + "Create a patch from STASH." + (interactive (list (magit-read-stash "Create patch from stash"))) + (with-temp-file (magit-rev-format "0001-%f.patch" stash) + (magit-git-insert "stash" "show" "-p" stash)) + (magit-refresh)) + +;;; Plumbing + +(defun magit-stash-save (message index worktree untracked + &optional refresh keep noerror ref) + (if (or (and index (magit-staged-files t)) + (and worktree (magit-unstaged-files t)) + (and untracked (magit-untracked-files (eq untracked 'all)))) + (magit-with-toplevel + (magit-stash-store message (or ref "refs/stash") + (magit-stash-create message index worktree untracked)) + (if (eq keep 'worktree) + (with-temp-buffer + (magit-git-insert "diff" "--cached" "--no-ext-diff") + (magit-run-git-with-input + "apply" "--reverse" "--cached" "--ignore-space-change" "-") + (magit-run-git-with-input + "apply" "--reverse" "--ignore-space-change" "-")) + (unless (eq keep t) + (if (eq keep 'index) + (magit-call-git "checkout" "--" ".") + (magit-call-git "reset" "--hard" "HEAD" "--")) + (when untracked + (magit-call-git "clean" "--force" "-d" + (and (eq untracked 'all) "-x"))))) + (when refresh + (magit-refresh))) + (unless noerror + (user-error "No %s changes to save" (cond ((not index) "unstaged") + ((not worktree) "staged") + (t "local")))))) + +(defun magit-stash-store (message ref commit) + (magit-update-ref ref message commit)) + +(defun magit-stash-create (message index worktree untracked) + (unless (magit-rev-parse "--verify" "HEAD") + (error "You do not have the initial commit yet")) + (let ((magit-git-global-arguments (nconc (list "-c" "commit.gpgsign=false") + magit-git-global-arguments)) + (default-directory (magit-toplevel)) + (summary (magit-stash-summary)) + (head "HEAD")) + (when (and worktree (not index)) + (setq head (or (magit-commit-tree "pre-stash index" nil "HEAD") + (error "Cannot save the current index state")))) + (or (setq index (magit-commit-tree (concat "index on " summary) nil head)) + (error "Cannot save the current index state")) + (and untracked + (setq untracked (magit-untracked-files (eq untracked 'all))) + (setq untracked (magit-with-temp-index nil nil + (or (and (magit-update-files untracked) + (magit-commit-tree + (concat "untracked files on " summary))) + (error "Cannot save the untracked files"))))) + (magit-with-temp-index index "-m" + (when worktree + (or (magit-update-files (magit-git-items "diff" "-z" "--name-only" head)) + (error "Cannot save the current worktree state"))) + (or (magit-commit-tree message nil head index untracked) + (error "Cannot save the current worktree state"))))) + +(defun magit-stash-summary () + (concat (or (magit-get-current-branch) "(no branch)") + ": " (magit-rev-format "%h %s"))) + +;;; Sections + +(defvar-keymap magit-stashes-section-map + :doc "Keymap for `stashes' section." + " " #'magit-stash-clear + " " #'magit-stash-list + "<2>" (magit-menu-item "Clear %t" #'magit-stash-clear) + "<1>" (magit-menu-item "List %t" #'magit-stash-list)) + +(defvar-keymap magit-stash-section-map + :doc "Keymap for `stash' sections." + " " #'magit-stash-pop + " " #'magit-stash-apply + " " #'magit-stash-drop + " " #'magit-stash-show + "<4>" (magit-menu-item "Pop %M" #'magit-stash-pop) + "<3>" (magit-menu-item "Apply %M" #'magit-stash-apply) + "<2>" (magit-menu-item "Delete %M" #'magit-stash-drop) + "<1>" (magit-menu-item "Visit %v" #'magit-stash-show)) + +(magit-define-section-jumper magit-jump-to-stashes + "Stashes" stashes "refs/stash" magit-insert-stashes) + +(cl-defun magit-insert-stashes (&optional (ref "refs/stash") + (heading "Stashes:")) + "Insert `stashes' section showing reflog for \"refs/stash\". +If optional REF is non-nil, show reflog for that instead. +If optional HEADING is non-nil, use that as section heading +instead of \"Stashes:\"." + (let ((verified (magit-rev-verify ref)) + (autostash (magit-rebase--get-state-lines "autostash"))) + (when (or autostash verified) + (magit-insert-section (stashes ref) + (magit-insert-heading heading) + (when autostash + (pcase-let ((`(,author ,date ,msg) + (split-string + (car (magit-git-lines + "show" "-q" "--format=%aN%x00%at%x00%s" + autostash)) + "\0"))) + (magit-insert-section (stash autostash) + (insert (propertize "AUTOSTASH" 'font-lock-face 'magit-hash)) + (insert " " msg "\n") + (magit-log-format-margin autostash author date)))) + (if verified + (magit-git-wash (apply-partially #'magit-log-wash-log 'stash) + "reflog" "--format=%gd%x00%aN%x00%at%x00%gs" ref) + (insert ?\n) + (magit-make-margin-overlay)))))) + +;;; List Stashes + +;;;###autoload +(defun magit-stash-list () + "List all stashes in a buffer." + (interactive) + (magit-stashes-setup-buffer)) + +(define-derived-mode magit-stashes-mode magit-reflog-mode "Magit Stashes" + "Mode for looking at lists of stashes." + :interactive nil + :group 'magit-log + (magit-hack-dir-local-variables)) + +(defun magit-stashes-setup-buffer () + (magit-setup-buffer #'magit-stashes-mode nil + (magit-buffer-refname "refs/stash"))) + +(defun magit-stashes-refresh-buffer () + (magit-insert-section (stashesbuf) + (magit-insert-heading t + (if (equal magit-buffer-refname "refs/stash") + "Stashes" + (format "Stashes [%s]" magit-buffer-refname))) + (magit-git-wash (apply-partially #'magit-log-wash-log 'stash) + "reflog" "--format=%gd%x00%aN%x00%at%x00%gs" magit-buffer-refname))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-stashes-mode)) + magit-buffer-refname) + +(defvar magit--update-stash-buffer nil) + +(defun magit-stashes-maybe-update-stash-buffer (&optional _) + "When moving in the stashes buffer, update the stash buffer. +If there is no stash buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-stashes-mode) + (magit--maybe-update-stash-buffer))) + +(defun magit--maybe-update-stash-buffer () + (when-let* ((stash (magit-section-value-if 'stash)) + (buffer (magit-get-mode-buffer 'magit-stash-mode nil t))) + (if magit--update-stash-buffer + (setq magit--update-stash-buffer (list stash buffer)) + (setq magit--update-stash-buffer (list stash buffer)) + (run-with-idle-timer + magit-update-other-window-delay nil + (let ((args (with-current-buffer buffer + (let ((magit-direct-use-buffer-arguments 'selected)) + (magit-show-commit--arguments))))) + (lambda () + (pcase-let ((`(,stash ,buf) magit--update-stash-buffer)) + (setq magit--update-stash-buffer nil) + (when (buffer-live-p buf) + (let ((magit-display-buffer-noselect t)) + (apply #'magit-stash-show stash args)))) + (setq magit--update-stash-buffer nil))))))) + +;;; Show Stash + +;;;###autoload +(defun magit-stash-show (stash &optional args files) + "Show all diffs of a stash in a buffer." + (interactive (cons (or (and (not current-prefix-arg) + (magit-stash-at-point)) + (magit-read-stash "Show stash")) + (pcase-let ((`(,args ,files) + (magit-diff-arguments 'magit-stash-mode))) + (list (delete "--stat" args) files)))) + (magit-stash-setup-buffer stash args files)) + +(define-derived-mode magit-stash-mode magit-diff-mode "Magit Stash" + "Mode for looking at individual stashes." + :interactive nil + :group 'magit-diff + (magit-hack-dir-local-variables) + (setq magit--imenu-group-types '(commit))) + +(put 'magit-stash-mode 'magit-diff-default-arguments + '("--no-ext-diff")) + +(defun magit-stash-setup-buffer (stash args files) + (magit-setup-buffer #'magit-stash-mode nil + (magit-buffer-revision stash) + (magit-buffer-range (format "%s^..%s" stash stash)) + (magit-buffer-diff-args args) + (magit-buffer-diff-files files))) + +(defun magit-stash-refresh-buffer () + (magit-set-header-line-format + (concat (capitalize magit-buffer-revision) " " + (propertize (magit-rev-format "%s" magit-buffer-revision) + 'font-lock-face + (list :weight 'normal :foreground + (face-attribute 'default :foreground))))) + (setq magit-buffer-revision-hash (magit-rev-parse magit-buffer-revision)) + (magit-insert-section (stash) + (magit-run-section-hook 'magit-stash-sections-hook))) + +(cl-defmethod magit-buffer-value (&context (major-mode magit-stash-mode)) + magit-buffer-revision) + +(defun magit-stash-insert-section (commit range message &optional files) + (magit-insert-section (commit commit) + (magit-insert-heading message) + (magit--insert-diff nil + "diff" range "-p" "--no-prefix" magit-buffer-diff-args + "--" (or files magit-buffer-diff-files)))) + +(defun magit-insert-stash-notes () + "Insert section showing notes for a stash. +This shows the notes for stash@{N} but not for the other commits +that make up the stash." + (magit-insert-section (note) + (magit-insert-heading t "Notes") + (magit-git-insert "notes" "show" magit-buffer-revision) + (magit-cancel-section 'if-empty) + (insert "\n"))) + +(defun magit-insert-stash-index () + "Insert section showing staged changes of the stash." + (magit-stash-insert-section + (format "%s^2" magit-buffer-revision) + (format "%s^..%s^2" magit-buffer-revision magit-buffer-revision) + "Staged")) + +(defun magit-insert-stash-worktree () + "Insert section showing unstaged changes of the stash." + (magit-stash-insert-section + magit-buffer-revision + (format "%s^2..%s" magit-buffer-revision magit-buffer-revision) + "Unstaged")) + +(defun magit-insert-stash-untracked () + "Insert section showing the untracked files commit of the stash." + (let ((stash magit-buffer-revision) + (rev (concat magit-buffer-revision "^3"))) + (when (magit-rev-verify rev) + (magit-stash-insert-section (format "%s^3" stash) + (format "%s^..%s^3" stash stash) + "Untracked files" + (magit-git-items "ls-tree" "-z" "--name-only" + "-r" "--full-tree" rev))))) + +;;; _ +(provide 'magit-stash) +;;; magit-stash.el ends here blob - /dev/null blob + b002776631e53876ea8f672625d12f2055fda02d (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-status.el @@ -0,0 +1,814 @@ +;;; magit-status.el --- The grand overview -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements the status buffer. + +;;; Code: + +(require 'magit) + +;;; Options + +(defgroup magit-status nil + "Inspect and manipulate Git repositories." + :link '(info-link "(magit)Status Buffer") + :group 'magit-modes) + +(defcustom magit-status-mode-hook nil + "Hook run after entering Magit-Status mode." + :group 'magit-status + :type 'hook) + +(defcustom magit-status-headers-hook + (list #'magit-insert-error-header + #'magit-insert-diff-filter-header + #'magit-insert-head-branch-header + #'magit-insert-upstream-branch-header + #'magit-insert-push-branch-header + #'magit-insert-tags-header) + "Hook run to insert headers into the status buffer. + +This hook is run by `magit-insert-status-headers', which in turn +has to be a member of `magit-status-sections-hook' to be used at +all." + :package-version '(magit . "2.1.0") + :group 'magit-status + :type 'hook + :options (list #'magit-insert-error-header + #'magit-insert-diff-filter-header + #'magit-insert-repo-header + #'magit-insert-remote-header + #'magit-insert-head-branch-header + #'magit-insert-upstream-branch-header + #'magit-insert-push-branch-header + #'magit-insert-tags-header)) + +(defcustom magit-status-sections-hook + (list #'magit-insert-status-headers + #'magit-insert-merge-log + #'magit-insert-rebase-sequence + #'magit-insert-am-sequence + #'magit-insert-sequencer-sequence + #'magit-insert-bisect-output + #'magit-insert-bisect-rest + #'magit-insert-bisect-log + #'magit-insert-untracked-files + #'magit-insert-unstaged-changes + #'magit-insert-staged-changes + #'magit-insert-stashes + #'magit-insert-unpushed-to-pushremote + #'magit-insert-unpushed-to-upstream-or-recent + #'magit-insert-unpulled-from-pushremote + #'magit-insert-unpulled-from-upstream) + "Hook run to insert sections into a status buffer." + :package-version '(magit . "2.12.0") + :group 'magit-status + :type 'hook) + +(defcustom magit-status-initial-section '(1) + "The section point is placed on when a status buffer is created. + +When such a buffer is merely being refreshed or being shown again +after it was merely buried, then this option has no effect. + +If this is nil, then point remains on the very first section as +usual. Otherwise it has to be a list of integers and section +identity lists. The members of that list are tried in order +until a matching section is found. + +An integer means to jump to the nth section, 1 for example +jumps over the headings. To get a section's \"identity list\" +use \\[universal-argument] \\[magit-describe-section-briefly]. + +If, for example, you want to jump to the commits that haven't +been pulled from the upstream, or else the second section, then +use: (((unpulled . \"..@{upstream}\") (status)) 1). + +See option `magit-section-initial-visibility-alist' for how to +control the initial visibility of the jumped to section." + :package-version '(magit . "2.90.0") + :group 'magit-status + :type '(choice (const :tag "As usual" nil) + (repeat (choice (number :tag "Nth top-level section") + (sexp :tag "Section identity"))))) + +(defcustom magit-status-goto-file-position nil + "Whether to go to position corresponding to file position. + +If this is non-nil and the current buffer is visiting a file, +then `magit-status' tries to go to the position in the status +buffer that corresponds to the position in the file-visiting +buffer. This jumps into either the diff of unstaged changes +or the diff of staged changes. + +If the previously current buffer does not visit a file, or if +the file has neither unstaged nor staged changes then this has +no effect. + +The command `magit-status-here' tries to go to that position, +regardless of the value of this option." + :package-version '(magit . "3.0.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-status-show-hashes-in-headers nil + "Whether headers in the status buffer show hashes. +The functions which respect this option are +`magit-insert-head-branch-header', +`magit-insert-upstream-branch-header', and +`magit-insert-push-branch-header'." + :package-version '(magit . "2.4.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-status-show-untracked-files t + "Whether to list untracked files in the status buffer. + +- If nil, do not list any untracked files. +- If t, list untracked files, but if a directory does not contain any + untracked files, then only list that directory, not the contained + untracked files. +- If all, then list each individual untracked files. This is can be + very slow and is discouraged. + +The corresponding values for the Git variable are \"no\", \"normal\" +and \"all\". + +To disable listing untracked files in a specific repository only, add +the following to \".dir-locals.el\": + + ((magit-status-mode + (magit-status-show-untracked-files . \"no\"))) + +Alternatively (and mostly for historic reasons), it is possible to use +`git-config' to set the repository-local value: + + git config set --local status.showUntrackedFiles no + +This does *not* override the (if any) local value of this Lisp variable, +but it does override its global value. + +See the last section in the git-status(1) manpage, to speed up the part +of the work Git is responsible for. Turning that list into sections is +also not free, so Magit only lists `magit-status-file-list-limit' files." + :package-version '(magit . "4.3.0") + :group 'magit-status + :type '(choice (const :tag "Do not list untracked files" nil) + (const :tag "List mixture of files and directories" t) + (const :tag "List individual files (slow)" all)) + :safe (##memq % '(nil t all))) + +(defcustom magit-status-file-list-limit 100 + "How many files to list in file list sections in the status buffer. +For performance reasons, it is recommended that you do not +increase this limit." + :package-version '(magit . "4.3.0") + :group 'magit-status + :type 'natnum) + +(defcustom magit-status-margin + (list nil + (nth 1 magit-log-margin) + 'magit-log-margin-width nil + (nth 4 magit-log-margin)) + "Format of the margin in `magit-status-mode' buffers. + +The value has the form (INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH). + +If INIT is non-nil, then the margin is shown initially. +STYLE controls how to format the author or committer date. + It can be one of `age' (to show the age of the commit), + `age-abbreviated' (to abbreviate the time unit to a character), + or a string (suitable for `format-time-string') to show the + actual date. Option `magit-log-margin-show-committer-date' + controls which date is being displayed. +WIDTH controls the width of the margin. This exists for forward + compatibility and currently the value should not be changed. +AUTHOR controls whether the name of the author is also shown by + default. +AUTHOR-WIDTH has to be an integer. When the name of the author + is shown, then this specifies how much space is used to do so." + :package-version '(magit . "2.9.0") + :group 'magit-status + :group 'magit-margin + :type magit-log-margin--custom-type + :initialize #'magit-custom-initialize-reset + :set-after '(magit-log-margin) + :set (apply-partially #'magit-margin-set-variable 'magit-status-mode)) + +(defcustom magit-status-use-buffer-arguments 'selected + "Whether `magit-status' reuses arguments when the buffer already exists. + +This option has no effect when merely refreshing the status +buffer using `magit-refresh'. + +Valid values are: + +`always': Always use the set of arguments that is currently + active in the status buffer, provided that buffer exists + of course. +`selected': Use the set of arguments from the status + buffer, but only if it is displayed in a window of the + current frame. This is the default. +`current': Use the set of arguments from the status buffer, + but only if it is the current buffer. +`never': Never use the set of arguments from the status + buffer." + :package-version '(magit . "3.0.0") + :group 'magit-buffers + :group 'magit-commands + :type '(choice + (const :tag "Always use args from buffer" always) + (const :tag "Use args from buffer if displayed in frame" selected) + (const :tag "Use args from buffer if it is current" current) + (const :tag "Never use args from buffer" never))) + +;;; Commands + +;;;###autoload +(defun magit-init (directory) + "Initialize a Git repository, then show its status. + +If the directory is below an existing repository, then the user +has to confirm that a new one should be created inside. If the +directory is the root of the existing repository, then the user +has to confirm that it should be reinitialized. + +Non-interactively DIRECTORY is (re-)initialized unconditionally." + (interactive + (let ((directory (file-name-as-directory + (expand-file-name + (read-directory-name "Create repository in: "))))) + (when-let ((toplevel (magit-toplevel directory))) + (setq toplevel (expand-file-name toplevel)) + (unless (y-or-n-p (if (file-equal-p toplevel directory) + (format "Reinitialize existing repository %s? " + directory) + (format "%s is a repository. Create another in %s? " + toplevel directory))) + (user-error "Abort"))) + (list directory))) + ;; `git init' does not understand the meaning of "~"! + (magit-call-git "init" (magit-convert-filename-for-git + (expand-file-name directory))) + (magit-status-setup-buffer directory)) + +;;;###autoload +(defun magit-status (&optional directory cache) + "Show the status of the current Git repository in a buffer. + +If the current directory isn't located within a Git repository, +then prompt for an existing repository or an arbitrary directory, +depending on option `magit-repository-directories', and show the +status of the selected repository instead. + +* If that option specifies any existing repositories, then offer + those for completion and show the status buffer for the + selected one. + +* Otherwise read an arbitrary directory using regular file-name + completion. If the selected directory is the top-level of an + existing working tree, then show the status buffer for that. + +* Otherwise offer to initialize the selected directory as a new + repository. After creating the repository show its status + buffer. + +These fallback behaviors can also be forced using one or more +prefix arguments: + +* With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) read an arbitrary directory and act on + it as described above. The same could be accomplished using + the command `magit-init'. + +* With a single prefix argument read an existing repository, or + if none can be found based on `magit-repository-directories', + then fall back to the same behavior as with two prefix + arguments." + (interactive + (let ((magit--refresh-cache (list (cons 0 0)))) + (list (and (or current-prefix-arg (not (magit-toplevel))) + (progn (magit--assert-usable-git) + (magit-read-repository + (>= (prefix-numeric-value current-prefix-arg) 16)))) + magit--refresh-cache))) + (let ((magit--refresh-cache (or cache (list (cons 0 0))))) + (if directory + (let ((toplevel (magit-toplevel directory))) + (setq directory (file-name-as-directory + (expand-file-name directory))) + (if (and toplevel (file-equal-p directory toplevel)) + (magit-status-setup-buffer directory) + (when (y-or-n-p + (if toplevel + (format "%s is a repository. Create another in %s? " + toplevel directory) + (format "Create repository in %s? " directory))) + ;; Creating a new repository invalidates cached values. + (setq magit--refresh-cache nil) + (magit-init directory)))) + (magit-status-setup-buffer default-directory)))) + +(put 'magit-status 'interactive-only 'magit-status-setup-buffer) + +;;;###autoload +(defalias 'magit #'magit-status + "Begin using Magit. + +This alias for `magit-status' exists for better discoverability. + +Instead of invoking this alias for `magit-status' using +\"M-x magit RET\", you should bind a key to `magit-status' +and read the info node `(magit)Getting Started', which +also contains other useful hints.") + +;;;###autoload +(defun magit-status-here () + "Like `magit-status' but with non-nil `magit-status-goto-file-position'." + (interactive) + (let ((magit-status-goto-file-position t)) + (call-interactively #'magit-status))) + +(put 'magit-status-here 'interactive-only 'magit-status-setup-buffer) + +;;;###autoload +(defun magit-status-quick () + "Show the status of the current Git repository, maybe without refreshing. + +If the status buffer of the current Git repository exists but +isn't being displayed in the selected frame, then display it +without refreshing it. + +If the status buffer is being displayed in the selected frame, +then also refresh it. + +Prefix arguments have the same meaning as for `magit-status', +and additionally cause the buffer to be refresh. + +To use this function instead of `magit-status', add this to your +init file: (global-set-key (kbd \"C-x g\") \\='magit-status-quick)." + (interactive) + (if-let ((buffer + (and (not current-prefix-arg) + (not (magit-get-mode-buffer 'magit-status-mode nil 'selected)) + (magit-get-mode-buffer 'magit-status-mode)))) + (magit-display-buffer buffer) + (call-interactively #'magit-status))) + +;;; Mode + +(defvar-keymap magit-status-mode-map + :doc "Keymap for `magit-status-mode'." + :parent magit-mode-map + "j" #'magit-status-jump + " " #'magit-dired-jump) + +(transient-define-prefix magit-status-jump () + "In a Magit-Status buffer, jump to a section." + [["Jump to" + ("z " magit-jump-to-stashes) + ("t " magit-jump-to-tracked) + ("n " magit-jump-to-untracked) + ("i " magit-jump-to-ignored) + ("u " magit-jump-to-unstaged) + ("s " magit-jump-to-staged)] + ["" + ("fu" magit-jump-to-unpulled-from-upstream) + ("fp" magit-jump-to-unpulled-from-pushremote) + ("pu" magit-jump-to-unpushed-to-upstream) + ("pp" magit-jump-to-unpushed-to-pushremote) + ("a " magit-jump-to-assume-unchanged) + ("w " magit-jump-to-skip-worktree)] + ["Jump using" + ("j" "Imenu" imenu)]]) + +(define-derived-mode magit-status-mode magit-mode "Magit" + "Mode for looking at Git status. + +This mode is documented in info node `(magit)Status Buffer'. + +\\\ +Type \\[magit-refresh] to refresh the current buffer. +Type \\[magit-section-toggle] to expand or hide the section at point. +Type \\[magit-visit-thing] to visit the change or commit at point. + +Type \\[magit-dispatch] to invoke major commands. + +Staging and applying changes is documented in info node +`(magit)Staging and Unstaging' and info node `(magit)Applying'. + +\\Type \ +\\[magit-apply] to apply the change at point, \ +\\[magit-stage] to stage, +\\[magit-unstage] to unstage, \ +\\[magit-discard] to discard, or \ +\\[magit-reverse] to reverse it. + +\\\ +Type \\[magit-commit] to create a commit. + +\\{magit-status-mode-map}" + :interactive nil + :group 'magit-status + (magit-hack-dir-local-variables) + (when magit-status-initial-section + (add-hook 'magit--initial-section-hook + #'magit-status-goto-initial-section nil t)) + (setq magit--imenu-group-types '(not branch commit))) + +(put 'magit-status-mode 'magit-diff-default-arguments + '("--no-ext-diff")) +(put 'magit-status-mode 'magit-log-default-arguments + '("-n256" "--decorate")) + +;;;###autoload +(defun magit-status-setup-buffer (&optional directory) + (unless directory + (setq directory default-directory)) + (when (file-remote-p directory) + (magit-git-version-assert)) + (let* ((default-directory directory) + (d (magit-diff--get-value 'magit-status-mode + magit-status-use-buffer-arguments)) + (l (magit-log--get-value 'magit-status-mode + magit-status-use-buffer-arguments)) + (file (and magit-status-goto-file-position + (magit-file-relative-name))) + (line (and file (save-restriction (widen) (line-number-at-pos)))) + (col (and file (save-restriction (widen) (current-column)))) + (buf (magit-setup-buffer #'magit-status-mode nil + (magit-buffer-diff-args (nth 0 d)) + (magit-buffer-diff-files (nth 1 d)) + (magit-buffer-log-args (nth 0 l)) + (magit-buffer-log-files (nth 1 l))))) + (when file + (with-current-buffer buf + (let ((staged (magit-get-section '((staged) (status))))) + (if (and staged + (cadr (magit-diff--locate-hunk file line staged))) + (magit-diff--goto-position file line col staged) + (let ((unstaged (magit-get-section '((unstaged) (status))))) + (unless (and unstaged + (magit-diff--goto-position file line col unstaged)) + (when staged + (magit-diff--goto-position file line col staged)))))))) + buf)) + +(defun magit-status-refresh-buffer () + (magit-git-exit-code "update-index" "--refresh") + (magit-insert-section (status) + (magit-run-section-hook 'magit-status-sections-hook))) + +(defun magit-status-goto-initial-section () + "Jump to the section specified by `magit-status-initial-section'." + (when-let ((section + (seq-some (lambda (initial) + (if (integerp initial) + (nth (1- initial) + (magit-section-siblings + (magit-current-section) 'next)) + (magit-get-section initial))) + magit-status-initial-section))) + (goto-char (oref section start)) + (when-let ((vis (cdr (assq 'magit-status-initial-section + magit-section-initial-visibility-alist)))) + (if (eq vis 'hide) + (magit-section-hide section) + (magit-section-show section))))) + +(defun magit-status-maybe-update-revision-buffer (&optional _) + "When moving in the status buffer, update the revision buffer. +If there is no revision buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-revision-buffer))) + +(defun magit-status-maybe-update-stash-buffer (&optional _) + "When moving in the status buffer, update the stash buffer. +If there is no stash buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-stash-buffer))) + +(defun magit-status-maybe-update-blob-buffer (&optional _) + "When moving in the status buffer, update the blob buffer. +If there is no blob buffer in the same frame, then do nothing. +See also info node `(magit)Section Movement'." + (when (derived-mode-p 'magit-status-mode) + (magit--maybe-update-blob-buffer))) + +;;; Sections +;;;; Special Headers + +(defun magit-insert-status-headers () + "Insert header sections appropriate for `magit-status-mode' buffers. +The sections are inserted by running the functions on the hook +`magit-status-headers-hook'." + (if (magit-rev-verify "HEAD") + (magit-insert-headers 'magit-status-headers-hook) + (insert "In the beginning there was darkness\n\n"))) + +(defvar-keymap magit-error-section-map + :doc "Keymap for `error' sections." + " " #'magit-process-buffer + "<1>" (magit-menu-item "Visit process output" #'magit-process-buffer)) + +(defun magit-insert-error-header () + "Insert the message about the Git error that just occurred. + +This function is only aware of the last error that occur when Git +was run for side-effects. If, for example, an error occurs while +generating a diff, then that error won't be inserted. Refreshing +the status buffer causes this section to disappear again." + (when magit-this-error + (magit-insert-section (error 'git) + (insert (propertize (format "%-10s" "GitError! ") + 'font-lock-face 'magit-section-heading)) + (insert (propertize magit-this-error 'font-lock-face 'error)) + (when-let ((magit-show-process-buffer-hint) + (key (car (where-is-internal 'magit-process-buffer)))) + (insert (format " [Type `%s' for details]" (key-description key)))) + (insert ?\n)) + (setq magit-this-error nil))) + +(defun magit-insert-diff-filter-header () + "Insert a header line showing the effective diff filters." + (let ((ignore-modules (magit-ignore-submodules-p))) + (when (or ignore-modules + magit-buffer-diff-files) + (insert (propertize (format "%-10s" "Filter! ") + 'font-lock-face 'magit-section-heading)) + (when ignore-modules + (insert ignore-modules) + (when magit-buffer-diff-files + (insert " -- "))) + (when magit-buffer-diff-files + (insert (string-join magit-buffer-diff-files " "))) + (insert ?\n)))) + +;;;; Reference Headers + +(defun magit-insert-head-branch-header (&optional branch) + "Insert a header line about the current branch. +If `HEAD' is detached, then insert information about that commit +instead. The optional BRANCH argument is for internal use only." + (let ((output (magit-rev-format "%h %s" (or branch "HEAD")))) + (string-match "^\\([^ ]+\\) \\(.*\\)" output) + (magit-bind-match-strings (commit summary) output + (when (equal summary "") + (setq summary "(no commit message)")) + (if-let ((branch (or branch (magit-get-current-branch)))) + (magit-insert-section (branch branch) + (insert (format "%-10s" "Head: ")) + (when magit-status-show-hashes-in-headers + (insert (propertize commit 'font-lock-face 'magit-hash) ?\s)) + (insert (propertize branch 'font-lock-face 'magit-branch-local)) + (insert ?\s) + (insert (magit-log--wash-summary summary)) + (insert ?\n)) + (magit-insert-section (commit commit) + (insert (format "%-10s" "Head: ")) + (insert (propertize commit 'font-lock-face 'magit-hash)) + (insert ?\s) + (insert (magit-log--wash-summary summary)) + (insert ?\n)))))) + +(defun magit-insert-upstream-branch-header (&optional branch upstream keyword) + "Insert a header line about the upstream of the current branch. +If no branch is checked out, then insert nothing. The optional +arguments are for internal use only." + (when-let ((branch (or branch (magit-get-current-branch)))) + (let ((remote (magit-get "branch" branch "remote")) + (merge (magit-get "branch" branch "merge")) + (rebase (magit-get "branch" branch "rebase"))) + (when (or remote merge) + (unless upstream + (setq upstream (magit-get-upstream-branch branch))) + (magit-insert-section (branch upstream) + (pcase rebase + ("true") + ("false" (setq rebase nil)) + (_ (setq rebase (magit-get-boolean "pull.rebase")))) + (insert (format "%-10s" (or keyword (if rebase "Rebase: " "Merge: ")))) + (insert + (if upstream + (concat (and magit-status-show-hashes-in-headers + (concat (propertize (magit-rev-format "%h" upstream) + 'font-lock-face 'magit-hash) + " ")) + upstream " " + (magit-log--wash-summary + (or (magit-rev-format "%s" upstream) + "(no commit message)"))) + (cond + ((magit--unnamed-upstream-p remote merge) + (concat (propertize merge 'font-lock-face 'magit-branch-remote) + " from " + (propertize remote 'font-lock-face 'bold))) + ((magit--valid-upstream-p remote merge) + (if (equal remote ".") + (concat + (propertize merge 'font-lock-face 'magit-branch-local) " " + (propertize "does not exist" + 'font-lock-face 'magit-branch-warning)) + (format + "%s %s %s" + (propertize merge 'font-lock-face 'magit-branch-remote) + (propertize "does not exist on" + 'font-lock-face 'magit-branch-warning) + (propertize remote 'font-lock-face 'magit-branch-remote)))) + (t + (propertize "invalid upstream configuration" + 'font-lock-face 'magit-branch-warning))))) + (insert ?\n)))))) + +(defun magit-insert-push-branch-header () + "Insert a header line about the branch the current branch is pushed to." + (when-let* ((branch (magit-get-current-branch)) + (target (magit-get-push-branch branch))) + (magit-insert-section (branch target) + (insert (format "%-10s" "Push: ")) + (insert + (if (magit-rev-verify target) + (concat (and magit-status-show-hashes-in-headers + (concat (propertize (magit-rev-format "%h" target) + 'font-lock-face 'magit-hash) + " ")) + target " " + (magit-log--wash-summary (or (magit-rev-format "%s" target) + "(no commit message)"))) + (let ((remote (magit-get-push-remote branch))) + (if (magit-remote-p remote) + (concat target " " + (propertize "does not exist" + 'font-lock-face 'magit-branch-warning)) + (concat remote " " + (propertize "remote does not exist" + 'font-lock-face 'magit-branch-warning)))))) + (insert ?\n)))) + +(defun magit-insert-tags-header () + "Insert a header line about the current and/or next tag." + (let* ((this-tag (magit-get-current-tag nil t)) + (next-tag (magit-get-next-tag nil t)) + (this-cnt (cadr this-tag)) + (next-cnt (cadr next-tag)) + (this-tag (car this-tag)) + (next-tag (car next-tag)) + (both-tags (and this-tag next-tag t))) + (when (or this-tag next-tag) + (magit-insert-section (tag (or this-tag next-tag)) + (insert (format "%-10s" (if both-tags "Tags: " "Tag: "))) + (cl-flet ((insert-count (tag count face) + (insert (concat (propertize tag 'font-lock-face 'magit-tag) + (and (> count 0) + (format " (%s)" + (propertize + (format "%s" count) + 'font-lock-face face))))))) + (when this-tag (insert-count this-tag this-cnt 'magit-branch-local)) + (when both-tags (insert ", ")) + (when next-tag (insert-count next-tag next-cnt 'magit-tag))) + (insert ?\n))))) + +;;;; Auxiliary Headers + +(defun magit-insert-user-header () + "Insert a header line about the current user." + (let ((name (magit-get "user.name")) + (email (magit-get "user.email"))) + (when (and name email) + (magit-insert-section (user name) + (insert (format "%-10s" "User: ")) + (insert (propertize name 'font-lock-face 'magit-log-author)) + (insert " <" email ">\n"))))) + +(defun magit-insert-repo-header () + "Insert a header line showing the path to the repository top-level." + (let ((topdir (magit-toplevel))) + (magit-insert-section (repo topdir) + (insert (format "%-10s%s\n" "Repo: " (abbreviate-file-name topdir)))))) + +(defun magit-insert-remote-header () + "Insert a header line about the remote of the current branch. + +If no remote is configured for the current branch, then fall back +showing the \"origin\" remote, or if that does not exist the first +remote in alphabetic order." + (when-let* ((name (magit-get-some-remote)) + ;; Under certain configurations it's possible for + ;; url to be nil, when name is not, see #2858. + (url (magit-get "remote" name "url"))) + (magit-insert-section (remote name) + (insert (format "%-10s" "Remote: ")) + (insert (propertize name 'font-lock-face 'magit-branch-remote) ?\s) + (insert url ?\n)))) + +;;;; File Sections + +(defvar-keymap magit-untracked-section-map + :doc "Keymap for the `untracked' section." + " " #'magit-discard + " " #'magit-stage + "<2>" (magit-menu-item "Discard files" #'magit-discard) + "<1>" (magit-menu-item "Stage files" #'magit-stage)) + +(magit-define-section-jumper magit-jump-to-untracked + "Untracked files" untracked nil magit-insert-untracked-files) + +(magit-define-section-jumper magit-jump-to-tracked + "Tracked files" tracked nil magit-insert-tracked-files) + +(magit-define-section-jumper magit-jump-to-ignored + "Ignored files" ignored nil magit-insert-ignored-files) + +(magit-define-section-jumper magit-jump-to-skip-worktree + "Skip-worktree files" skip-worktree nil magit-insert-skip-worktree-files) + +(magit-define-section-jumper magit-jump-to-assume-unchanged + "Assume-unchanged files" assume-unchanged nil + magit-insert-assume-unchanged-files) + +(defun magit-insert-untracked-files () + "Maybe insert a list of untracked files. + +List files if `magit-status-show-untracked-files' is non-nil, but also +take the local value of Git variable `status.showUntrackedFiles' into +account. The local value of the Lisp variable takes precedence over the +local value of the Git variable. The global value of the Git variable +is always ignored." + (magit-insert-files 'untracked #'magit-list-untracked-files)) + +(defun magit-insert-tracked-files () + "Insert a list of tracked files. +Honor the buffer's file filter, which can be set using \"D - -\"." + (magit-insert-files 'tracked #'magit-list-files)) + +(defun magit-insert-ignored-files () + "Insert a list of ignored files. +Honor the buffer's file filter, which can be set using \"D - -\"." + (magit-insert-files 'ignored (##magit-ignored-files "--directory" %))) + +(defun magit-insert-skip-worktree-files () + "Insert a list of skip-worktree files. +Honor the buffer's file filter, which can be set using \"D - -\"." + (magit-insert-files 'skip-worktree #'magit-skip-worktree-files)) + +(defun magit-insert-assume-unchanged-files () + "Insert a list of files that are assumed to be unchanged. +Honor the buffer's file filter, which can be set using \"D - -\"." + (magit-insert-files 'assume-unchanged #'magit-assume-unchanged-files)) + +(defun magit-insert-files (type fn) + (when-let ((files (funcall fn + (and magit-buffer-diff-files + (cons "--" magit-buffer-diff-files))))) + (magit-insert-section section ((eval type) nil t) + (magit-insert-heading (length files) + (let ((title (symbol-name type))) + (format "%c%s files" + (capitalize (aref title 0)) + (substring title 1)))) + (magit-insert-section-body + (let ((magit-section-insert-in-reverse t) + (limit magit-status-file-list-limit)) + (while (and files (> limit 0)) + (cl-decf limit) + (let ((file (pop files))) + (magit-insert-section (file file) + (insert (funcall magit-format-file-function + 'list file 'magit-filename)) + (insert ?\n)))) + (when files + (magit-insert-section (info) + (insert (propertize + (format "%s files not listed\n" (length files)) + 'face 'warning))))) + (insert ?\n) + (oset section children (nreverse (oref section children))))))) + +;;; _ +(provide 'magit-status) +;;; magit-status.el ends here blob - /dev/null blob + 9d2b3368b6d836bbdc59db0bf1938a9479df6504 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-submodule.el @@ -0,0 +1,716 @@ +;;; magit-submodule.el --- Submodule support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for "git submodule". + +;; See (info "(magit)Submodules"). + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-module-sections-hook + (list #'magit-insert-modules-overview + #'magit-insert-modules-unpulled-from-upstream + #'magit-insert-modules-unpulled-from-pushremote + #'magit-insert-modules-unpushed-to-upstream + #'magit-insert-modules-unpushed-to-pushremote) + "Hook run by `magit-insert-modules'. + +That function isn't part of `magit-status-sections-hook's default +value, so you have to add it yourself for this hook to have any +effect." + :package-version '(magit . "2.11.0") + :group 'magit-status + :type 'hook) + +(defcustom magit-module-sections-nested t + "Whether `magit-insert-modules' wraps inserted sections. + +If this is non-nil, then only a single top-level section +is inserted. If it is nil, then all sections listed in +`magit-module-sections-hook' become top-level sections." + :package-version '(magit . "2.11.0") + :group 'magit-status + :type 'boolean) + +(defcustom magit-submodule-list-mode-hook (list #'hl-line-mode) + "Hook run after entering Magit-Submodule-List mode." + :package-version '(magit . "2.9.0") + :group 'magit-repolist + :type 'hook + :get 'magit-hook-custom-get + :options (list #'hl-line-mode)) + +(defcustom magit-submodule-list-columns + `(("Path" 25 ,#'magit-modulelist-column-path + ()) + ("Version" 25 ,#'magit-repolist-column-version + ((:sort magit-repolist-version<))) + ("Branch" 20 ,#'magit-repolist-column-branch + ()) + ("BP" 3 ,#'magit-repolist-column-unpushed-to-pushremote + ((:right-align t) + (:sort <))) + ("B>U" 3 ,#'magit-repolist-column-unpushed-to-upstream + ((:right-align t) + (:sort <))) + ("S" 3 ,#'magit-repolist-column-stashes + ((:right-align t) + (:sort <))) + ("B" 3 ,#'magit-repolist-column-branches + ((:right-align t) + (:sort <)))) + "List of columns displayed by `magit-list-submodules'. + +Each element has the form (HEADER WIDTH FORMAT PROPS). + +HEADER is the string displayed in the header. WIDTH is the width +of the column. FORMAT is a function that is called with one +argument, the repository identification (usually its basename), +and with `default-directory' bound to the toplevel of its working +tree. It has to return a string to be inserted or nil. PROPS is +an alist that supports the keys `:right-align', `:pad-right' and +`:sort'. + +The `:sort' function has a weird interface described in the +docstring of `tabulated-list--get-sort'. Alternatively `<' and +`magit-repolist-version<' can be used as those functions are +automatically replaced with functions that satisfy the interface. +Set `:sort' to nil to inhibit sorting; if unspecified, then the +column is sortable using the default sorter. + +You may wish to display a range of numeric columns using just one +character per column and without any padding between columns, in +which case you should use an appropriate HEADER, set WIDTH to 1, +and set `:pad-right' to 0. \"+\" is substituted for numbers higher +than 9." + :package-version '(magit . "2.8.0") + :group 'magit-repolist + :type `(repeat (list :tag "Column" + (string :tag "Header Label") + (integer :tag "Column Width") + (function :tag "Inserter Function") + (repeat :tag "Properties" + (list (choice :tag "Property" + (const :right-align) + (const :pad-right) + (const :sort) + (symbol)) + (sexp :tag "Value")))))) + +(defcustom magit-submodule-list-sort-key '("Path" . nil) + "Initial sort key for buffer created by `magit-list-submodules'. +If nil, no additional sorting is performed. Otherwise, this +should be a cons cell (NAME . FLIP). NAME is a string matching +one of the column names in `magit-submodule-list-columns'. FLIP, +if non-nil, means to invert the resulting sort." + :package-version '(magit . "3.2.0") + :group 'magit-repolist + :type '(choice (const nil) + (cons (string :tag "Column name") + (boolean :tag "Flip order")))) + +(defvar magit-submodule-list-format-path-functions nil) + +(defcustom magit-submodule-remove-trash-gitdirs nil + "Whether `magit-submodule-remove' offers to trash module gitdirs. + +If this is nil, then that command does not offer to do so unless +a prefix argument is used. When this is t, then it does offer to +do so even without a prefix argument. + +In both cases the action still has to be confirmed unless that is +disabled using the option `magit-no-confirm'. Doing the latter +and also setting this variable to t will lead to tears." + :package-version '(magit . "2.90.0") + :group 'magit-commands + :type 'boolean) + +;;; Popup + +;;;###autoload (autoload 'magit-submodule "magit-submodule" nil t) +(transient-define-prefix magit-submodule () + "Act on a submodule." + :man-page "git-submodule" + ["Arguments" + ("-f" "Force" ("-f" "--force")) + ("-r" "Recursive" "--recursive") + ("-N" "Do not fetch" ("-N" "--no-fetch")) + ("-C" "Checkout tip" "--checkout") + ("-R" "Rebase onto tip" "--rebase") + ("-M" "Merge tip" "--merge") + ("-U" "Use upstream tip" "--remote")] + ["One module actions" + ("a" magit-submodule-add) + ("r" magit-submodule-register) + ("p" magit-submodule-populate) + ("u" magit-submodule-update) + ("s" magit-submodule-synchronize) + ("d" magit-submodule-unpopulate) + ("k" "Remove" magit-submodule-remove)] + ["Populated modules actions" + ("l" "List modules" magit-list-submodules) + ("f" "Fetch modules" magit-fetch-modules)]) + +(defun magit-submodule-arguments (&rest filters) + (seq-filter (##and (member % filters) %) + (transient-args 'magit-submodule))) + +(defclass magit--git-submodule-suffix (transient-suffix) + ()) + +(cl-defmethod transient-format-description ((obj magit--git-submodule-suffix)) + (let ((value (delq nil (mapcar #'transient-infix-value transient--suffixes)))) + (replace-regexp-in-string + "\\[--[^]]+\\]" + (lambda (match) + (format (propertize "[%s]" 'face 'transient-inactive-argument) + (mapconcat (lambda (arg) + (propertize arg 'face + (if (member arg value) + 'transient-argument + 'transient-inactive-argument))) + (save-match-data + (split-string (substring match 1 -1) "|")) + (propertize "|" 'face 'transient-inactive-argument)))) + (cl-call-next-method obj)))) + +;;;###autoload (autoload 'magit-submodule-add "magit-submodule" nil t) +(transient-define-suffix magit-submodule-add (url &optional path name args) + "Add the repository at URL as a module. + +Optional PATH is the path to the module relative to the root of +the superproject. If it is nil, then the path is determined +based on the URL. Optional NAME is the name of the module. If +it is nil, then PATH also becomes the name." + :class 'magit--git-submodule-suffix + :description "Add git submodule add [--force]" + (interactive + (magit-with-toplevel + (let* ((url (magit-read-string-ns "Add submodule (remote url)")) + (path (magit-submodule-read-path "Add submodules at path: " url))) + (list url + (directory-file-name path) + (magit-submodule-read-name-for-path path) + (magit-submodule-arguments "--force"))))) + (magit-submodule-add-1 url path name args)) + +(defun magit-submodule-read-path (prompt url) + (directory-file-name + (file-relative-name + (read-directory-name prompt nil nil nil + (and (string-match "\\([^./]+\\)\\(\\.git\\)?$" url) + (match-string 1 url)))))) + +(defun magit-submodule-add-1 (url &optional path name args) + (magit-with-toplevel + (magit-submodule--maybe-reuse-gitdir name path) + (magit-run-git-async "submodule" "add" + (and name (list "--name" name)) + args "--" url path) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (if (> (process-exit-status process) 0) + (magit-process-sentinel process event) + (process-put process 'inhibit-refresh t) + (magit-process-sentinel process event) + (magit-call-git "submodule" "absorbgitdirs" path) + (magit-refresh))))))) + +;;;###autoload +(defun magit-submodule-read-name-for-path (path &optional prefer-short) + (let* ((path (directory-file-name (file-relative-name path))) + (name (file-name-nondirectory path))) + (push (if prefer-short path name) minibuffer-history) + (magit-read-string-ns + "Submodule name" nil (cons 'minibuffer-history 2) + (or (seq-keep (##pcase-let ((`(,var ,val) (split-string % "="))) + (and (equal val path) + (cadr (split-string var "\\.")))) + (magit-git-lines "config" "--list" "-f" ".gitmodules")) + (if prefer-short name path))))) + +;;;###autoload (autoload 'magit-submodule-register "magit-submodule" nil t) +(transient-define-suffix magit-submodule-register (modules) + "Register MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; This command and the underlying "git submodule init" do NOT + ;; "initialize" modules. They merely "register" modules in the + ;; super-projects $GIT_DIR/config file, the purpose of which is to + ;; allow users to change such values before actually initializing + ;; the modules. + :description "Register git submodule init" + (interactive + (list (magit-module-confirm "Register" 'magit-module-no-worktree-p))) + (magit-with-toplevel + (magit-run-git-async "submodule" "init" "--" modules))) + +;;;###autoload (autoload 'magit-submodule-populate "magit-submodule" nil t) +(transient-define-suffix magit-submodule-populate (modules args) + "Create MODULES working directories, checking out the recorded commits. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; This is the command that actually "initializes" modules. + ;; A module is initialized when it has a working directory, + ;; a gitlink, and a .gitmodules entry. + :class 'magit--git-submodule-suffix + :description "Populate git submodule update --init [--recursive]" + (interactive + (list (magit-module-confirm "Populate" 'magit-module-no-worktree-p) + (magit-submodule-arguments "--recursive"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "update" "--init" args "--" modules))) + +;;;###autoload (autoload 'magit-submodule-update "magit-submodule" nil t) +(transient-define-suffix magit-submodule-update (modules args) + "Update MODULES by checking out the recorded commits. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; Unlike `git-submodule's `update' command ours can only update + ;; "initialized" modules by checking out other commits but not + ;; "initialize" modules by creating the working directories. + ;; To do the latter we provide the "setup" command. + :class 'magit--git-submodule-suffix + :description "Update git submodule update [--force] [--no-fetch] + [--remote] [--recursive] [--checkout|--rebase|--merge]" + (interactive + (list (magit-module-confirm "Update" 'magit-module-worktree-p) + (magit-submodule-arguments + "--force" "--remote" "--recursive" "--checkout" "--rebase" "--merge" + "--no-fetch"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "update" args "--" modules))) + +;;;###autoload (autoload 'magit-submodule-synchronize "magit-submodule" nil t) +(transient-define-suffix magit-submodule-synchronize (modules args) + "Synchronize url configuration of MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + :class 'magit--git-submodule-suffix + :description "Synchronize git submodule sync [--recursive]" + (interactive + (list (magit-module-confirm "Synchronize" 'magit-module-worktree-p) + (magit-submodule-arguments "--recursive"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "sync" args "--" modules))) + +;;;###autoload (autoload 'magit-submodule-unpopulate "magit-submodule" nil t) +(transient-define-suffix magit-submodule-unpopulate (modules args) + "Remove working directories of MODULES. + +With a prefix argument act on all suitable modules. Otherwise, +if the region selects modules, then act on those. Otherwise, if +there is a module at point, then act on that. Otherwise read a +single module from the user." + ;; Even when a submodule is "uninitialized" (it has no worktree) + ;; the super-project's $GIT_DIR/config may never-the-less set the + ;; module's url. This may happen if you `deinit' and then `init' + ;; to register (NOT initialize). Because the purpose of `deinit' + ;; is to remove the working directory AND to remove the url, this + ;; command does not limit itself to modules that have no working + ;; directory. + :class 'magit--git-submodule-suffix + :description "Unpopulate git submodule deinit [--force]" + (interactive + (list (magit-module-confirm "Unpopulate") + (magit-submodule-arguments "--force"))) + (magit-with-toplevel + (magit-run-git-async "submodule" "deinit" args "--" modules))) + +;;;###autoload +(defun magit-submodule-remove (modules args trash-gitdirs) + "Unregister MODULES and remove their working directories. + +For safety reasons, do not remove the gitdirs and if a module has +uncommitted changes, then do not remove it at all. If a module's +gitdir is located inside the working directory, then move it into +the gitdir of the superproject first. + +With the \"--force\" argument offer to remove dirty working +directories and with a prefix argument offer to delete gitdirs. +Both actions are very dangerous and have to be confirmed. There +are additional safety precautions in place, so you might be able +to recover from making a mistake here, but don't count on it." + (interactive + (list (if-let ((modules (magit-region-values 'magit-module-section t))) + (magit-confirm 'remove-modules nil "Remove %d modules" nil modules) + (list (magit-read-module-path "Remove module"))) + (magit-submodule-arguments "--force") + current-prefix-arg)) + (when magit-submodule-remove-trash-gitdirs + (setq trash-gitdirs t)) + (magit-with-toplevel + (when-let + ((modified + (seq-filter (lambda (module) + (let ((default-directory (file-name-as-directory + (expand-file-name module)))) + (and (cddr (directory-files default-directory)) + (magit-anything-modified-p)))) + modules))) + (if (member "--force" args) + (if (magit-confirm 'remove-dirty-modules + "Remove dirty module %s" + "Remove %d dirty modules" + t modified) + (dolist (module modified) + (let ((default-directory (file-name-as-directory + (expand-file-name module)))) + (magit-git "stash" "push" + "-m" "backup before removal of this module"))) + (setq modules (cl-set-difference modules modified :test #'equal))) + (if (cdr modified) + (message "Omitting %s modules with uncommitted changes: %s" + (length modified) + (string-join modified ", ")) + (message "Omitting module %s, it has uncommitted changes" + (car modified))) + (setq modules (cl-set-difference modules modified :test #'equal)))) + (when modules + (let ((alist + (and trash-gitdirs + (mapcar (##split-string % "\0") + (magit-git-lines "submodule" "foreach" "-q" + "printf \"$sm_path\\0$name\n\""))))) + (magit-git "submodule" "absorbgitdirs" "--" modules) + (magit-git "submodule" "deinit" args "--" modules) + (magit-git "rm" args "--" modules) + (when (and trash-gitdirs + (magit-confirm 'trash-module-gitdirs + "Trash gitdir of module %s" + "Trash gitdirs of %d modules" + t modules)) + (dolist (module modules) + (if-let ((name (cadr (assoc module alist)))) + ;; Disregard if `magit-delete-by-moving-to-trash' + ;; is nil. Not doing so would be too dangerous. + (delete-directory (convert-standard-filename + (expand-file-name + (concat "modules/" name) + (magit-gitdir))) + t t) + (error "BUG: Weird module name and/or path for %s" module))))) + (magit-refresh)))) + +;;; Sections + +;;;###autoload +(defun magit-insert-modules () + "Insert submodule sections. +Hook `magit-module-sections-hook' controls which module sections +are inserted, and option `magit-module-sections-nested' controls +whether they are wrapped in an additional section." + (when-let ((modules (magit-list-module-paths))) + (if magit-module-sections-nested + (magit-insert-section (modules nil t) + (magit-insert-heading + (format "%s (%s)" + (propertize "Modules" + 'font-lock-face 'magit-section-heading) + (length modules))) + (magit-insert-section-body + (magit--insert-modules))) + (magit--insert-modules)))) + +(defun magit--insert-modules (&optional _section) + (magit-run-section-hook 'magit-module-sections-hook)) + +;;;###autoload +(defun magit-insert-modules-overview () + "Insert sections for all modules. +For each section insert the path and the output of `git describe --tags', +or, failing that, the abbreviated HEAD commit hash." + (when-let ((modules (magit-list-module-paths))) + (magit-insert-section (modules nil t) + (magit-insert-heading + (format "%s (%s)" + (propertize "Modules overview" + 'font-lock-face 'magit-section-heading) + (length modules))) + (magit-insert-section-body + (magit--insert-modules-overview))))) + +(defvar magit-modules-overview-align-numbers t) + +(defun magit--insert-modules-overview (&optional _section) + (magit-with-toplevel + (let* ((modules (magit-list-module-paths)) + (path-format (format "%%-%ds " + (min (apply #'max (mapcar #'length modules)) + (/ (window-width) 2)))) + (branch-format (format "%%-%ds " (min 25 (/ (window-width) 3))))) + (dolist (module modules) + (let ((default-directory + (expand-file-name (file-name-as-directory module)))) + (magit-insert-section (module module t) + (insert (propertize (format path-format module) + 'font-lock-face 'magit-diff-file-heading)) + (if (not (file-exists-p ".git")) + (insert "(unpopulated)") + (insert + (format + branch-format + (if-let ((branch (magit-get-current-branch))) + (propertize branch 'font-lock-face 'magit-branch-local) + (propertize "(detached)" 'font-lock-face 'warning)))) + (if-let ((desc (magit-git-string "describe" "--tags"))) + (progn (when (and magit-modules-overview-align-numbers + (string-match-p "\\`[0-9]" desc)) + (insert ?\s)) + (insert (propertize desc 'font-lock-face 'magit-tag))) + (when-let ((abbrev (magit-rev-format "%h"))) + (insert (propertize abbrev 'font-lock-face 'magit-hash))))) + (insert ?\n)))))) + (insert ?\n)) + +(defvar-keymap magit-modules-section-map + :doc "Keymap for `modules' sections." + " " #'magit-list-submodules + "<1>" (magit-menu-item "List %t" #'magit-list-submodules)) + +(defvar-keymap magit-module-section-map + :doc "Keymap for `module' sections." + "C-j" #'magit-submodule-visit + "C-" #'magit-submodule-visit + " " #'magit-unstage + " " #'magit-stage + " " #'magit-submodule-visit + "<5>" (magit-menu-item "Module commands..." #'magit-submodule) + "<4>" '(menu-item "--") + "<3>" (magit-menu-item "Unstage %T" #'magit-unstage + '(:visible (eq (magit-diff-type) 'staged))) + "<2>" (magit-menu-item "Stage %T" #'magit-stage + '(:visible (eq (magit-diff-type) 'unstaged))) + "<1>" (magit-menu-item "Visit %s" #'magit-submodule-visit)) + +(defun magit-submodule-visit (module &optional other-window) + "Visit MODULE by calling `magit-status' on it. +Offer to initialize MODULE if it's not checked out yet. +With a prefix argument, visit in another window." + (interactive (list (or (magit-section-value-if 'module) + (magit-read-module-path "Visit module")) + current-prefix-arg)) + (magit-with-toplevel + (let ((path (expand-file-name module))) + (cond + ((file-exists-p (expand-file-name ".git" module)) + (magit-diff-visit-directory path other-window)) + ((y-or-n-p (format "Initialize submodule '%s' first?" module)) + (magit-run-git-async "submodule" "update" "--init" "--" module) + (set-process-sentinel + magit-this-process + (lambda (process event) + (let ((magit-process-raise-error t)) + (magit-process-sentinel process event)) + (when (and (eq (process-status process) 'exit) + (= (process-exit-status process) 0)) + (magit-diff-visit-directory path other-window))))) + ((file-exists-p path) + (dired-jump other-window (concat path "/."))))))) + +;;;###autoload +(defun magit-insert-modules-unpulled-from-upstream () + "Insert sections for modules that haven't been pulled from the upstream. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpulled from @{upstream}" + 'modules-unpulled-from-upstream + "HEAD..@{upstream}")) + +;;;###autoload +(defun magit-insert-modules-unpulled-from-pushremote () + "Insert sections for modules that haven't been pulled from the push-remote. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpulled from @{push}" + 'modules-unpulled-from-pushremote + "HEAD..@{push}")) + +;;;###autoload +(defun magit-insert-modules-unpushed-to-upstream () + "Insert sections for modules that haven't been pushed to the upstream. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unmerged into @{upstream}" + 'modules-unpushed-to-upstream + "@{upstream}..HEAD")) + +;;;###autoload +(defun magit-insert-modules-unpushed-to-pushremote () + "Insert sections for modules that haven't been pushed to the push-remote. +These sections can be expanded to show the respective commits." + (magit--insert-modules-logs "Modules unpushed to @{push}" + 'modules-unpushed-to-pushremote + "@{push}..HEAD")) + +(defun magit--insert-modules-logs (heading type range) + "For internal use, don't add to a hook." + (when-let (((not (magit-ignore-submodules-p))) + (modules (magit-list-module-paths))) + (magit-insert-section ((eval type) nil t) + (string-match "\\`\\(.+\\) \\([^ ]+\\)\\'" heading) + (magit-insert-heading + (propertize (match-string 1 heading) + 'font-lock-face 'magit-section-heading) + " " + (propertize (match-string 2 heading) + 'font-lock-face 'magit-branch-remote) + ":") + (dolist (module modules) + (when-let* ((default-directory (expand-file-name module)) + ((file-exists-p (expand-file-name ".git"))) + (lines (magit-git-lines "-c" "push.default=current" + "log" "--oneline" range)) + (count (length lines)) + ((> count 0))) + (magit-insert-section + ( module module t + :range range) + (magit-insert-heading count + (propertize module 'font-lock-face 'magit-diff-file-heading)) + (dolist (line lines) + (string-match magit-log-module-re line) + (let ((rev (match-string 1 line)) + (msg (match-string 2 line))) + (magit-insert-section (module-commit rev t) + (insert (propertize rev 'font-lock-face 'magit-hash) " " + (magit-log--wash-summary msg) "\n"))))))) + (magit-cancel-section 'if-empty) + (insert ?\n)))) + +;;; List + +;;;###autoload +(defun magit-list-submodules () + "Display a list of the current repository's populated submodules." + (interactive) + (magit-submodule-list-setup magit-submodule-list-columns)) + +(defvar-keymap magit-submodule-list-mode-map + :doc "Local keymap for Magit-Submodule-List mode buffers." + :parent magit-repolist-mode-map) + +(define-derived-mode magit-submodule-list-mode magit-repolist-mode "Modules" + "Major mode for browsing a list of Git submodules." + :interactive nil + :group 'magit-repolist + (setq-local tabulated-list-revert-hook + (list #'magit-submodule-list-refresh t))) + +(defvar-local magit-submodule-list-predicate nil) + +(defun magit-submodule-list-setup (columns &optional predicate) + (magit-display-buffer + (or (magit-get-mode-buffer 'magit-submodule-list-mode) + (magit-generate-new-buffer 'magit-submodule-list-mode))) + (magit-submodule-list-mode) + (setq-local magit-repolist-columns columns) + (setq-local magit-repolist-sort-key magit-submodule-list-sort-key) + (setq-local magit-submodule-list-predicate predicate) + (magit-repolist-setup-1) + (magit-submodule-list-refresh)) + +(defun magit-submodule-list-refresh () + (setq tabulated-list-entries + (seq-keep + (lambda (module) + (let ((default-directory + (expand-file-name (file-name-as-directory module)))) + (and (file-exists-p ".git") + (or (not magit-submodule-list-predicate) + (funcall magit-submodule-list-predicate module)) + (list default-directory + (vconcat + (mapcar (pcase-lambda (`(,title ,width ,fn ,props)) + (or (funcall fn `((:path ,module) + (:title ,title) + (:width ,width) + ,@props)) + "")) + magit-repolist-columns)))))) + (magit-list-module-paths))) + (message "Listing submodules...") + (tabulated-list-init-header) + (tabulated-list-print t) + (message "Listing submodules...done")) + +(defun magit-modulelist-column-path (spec) + "Insert the relative path of the submodule." + (let ((path (cadr (assq :path spec)))) + (or (run-hook-with-args-until-success + 'magit-submodule-list-format-path-functions path) + path))) + +;;; Utilities + +(defun magit-submodule--maybe-reuse-gitdir (name path) + (let ((gitdir (convert-standard-filename + (expand-file-name (concat "modules/" name) + (magit-gitdir))))) + (when (and (file-exists-p gitdir) + (not (file-exists-p path))) + (pcase (read-char-choice + (concat + gitdir " already exists.\n" + "Type [u] to use the existing gitdir and create the working tree\n" + " [r] to rename the existing gitdir and clone again\n" + " [t] to trash the existing gitdir and clone again\n" + " [C-g] to abort ") + '(?u ?r ?t)) + (?u (magit-submodule--restore-worktree (expand-file-name path) gitdir)) + (?r (rename-file gitdir (concat gitdir "-" + (format-time-string "%F-%T")))) + (?t (delete-directory gitdir t t)))))) + +(defun magit-submodule--restore-worktree (worktree gitdir) + (make-directory worktree t) + (with-temp-file (expand-file-name ".git" worktree) + (insert "gitdir: " (file-relative-name gitdir worktree) "\n")) + (let ((default-directory worktree)) + (magit-call-git "reset" "--hard" "HEAD" "--"))) + +;;; _ +(provide 'magit-submodule) +;;; magit-submodule.el ends here blob - /dev/null blob + b771a23e4543692886dfc33fb1e936a1cef43c02 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-subtree.el @@ -0,0 +1,187 @@ +;;; magit-subtree.el --- Subtree support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for "git subtree". +;; The entry point is the `magit-subtree' menu command. + +;; See (info "(magit)Subtree"). + +;;; Code: + +(require 'magit) + +;;; Commands + +;;;###autoload (autoload 'magit-subtree "magit-subtree" nil t) +(transient-define-prefix magit-subtree () + "Import or export subtrees." + :man-page "git-subtree" + ["Subtree actions" + ("i" "Import" magit-subtree-import) + ("e" "Export" magit-subtree-export)]) + +;;;###autoload (autoload 'magit-subtree-import "magit-subtree" nil t) +(transient-define-prefix magit-subtree-import () + "Import subtrees." + :man-page "git-subtree" + ["Arguments" + (magit-subtree:--prefix) + (magit-subtree:--message) + ("-s" "Squash" "--squash")] + ["Subtree import actions" + [("a" "Add" magit-subtree-add) + ("c" "Add commit" magit-subtree-add-commit)] + [("m" "Merge" magit-subtree-merge) + ("f" "Pull" magit-subtree-pull)]]) + +;;;###autoload (autoload 'magit-subtree-export "magit-subtree" nil t) +(transient-define-prefix magit-subtree-export () + "Export subtrees." + :man-page "git-subtree" + ["Arguments" + (magit-subtree:--prefix) + (magit-subtree:--annotate) + (magit-subtree:--branch) + (magit-subtree:--onto) + ("-i" "Ignore joins" "--ignore-joins") + ("-j" "Rejoin" "--rejoin")] + ["Subtree export actions" + ("p" "Push" magit-subtree-push) + ("s" "Split" magit-subtree-split)]) + +(transient-define-argument magit-subtree:--prefix () + :description "Prefix" + :class 'transient-option + :shortarg "-P" + :argument "--prefix=" + :reader #'magit-subtree-read-prefix) + +(defun magit-subtree-read-prefix (prompt &optional default _history) + (let* ((insert-default-directory nil) + (topdir (magit-toplevel)) + (prefix (read-directory-name (concat prompt ": ") topdir default))) + (if (file-name-absolute-p prefix) + (if (string-prefix-p topdir prefix) + (file-relative-name prefix topdir) + (user-error "%s isn't inside the repository at %s" prefix topdir)) + prefix))) + +(transient-define-argument magit-subtree:--message () + :description "Message" + :class 'transient-option + :shortarg "-m" + :argument "--message=") + +(transient-define-argument magit-subtree:--annotate () + :description "Annotate" + :class 'transient-option + :key "-a" + :argument "--annotate=") + +(transient-define-argument magit-subtree:--branch () + :description "Branch" + :class 'transient-option + :shortarg "-b" + :argument "--branch=") + +(transient-define-argument magit-subtree:--onto () + :description "Onto" + :class 'transient-option + :key "-o" + :argument "--onto=" + :reader #'magit-transient-read-revision) + +(defun magit-subtree-prefix (transient prompt) + (if-let ((arg (seq-find (##string-prefix-p "--prefix=" %) + (transient-args transient)))) + (substring arg 9) + (magit-subtree-read-prefix prompt))) + +(defun magit-subtree-arguments (transient) + (seq-remove (##string-prefix-p "--prefix=" %) + (transient-args transient))) + +(defun magit-git-subtree (subcmd prefix &rest args) + (magit-run-git-async "subtree" subcmd (concat "--prefix=" prefix) args)) + +;;;###autoload +(defun magit-subtree-add (prefix repository ref args) + "Add REF from REPOSITORY as a new subtree at PREFIX." + (interactive + (cons (magit-subtree-prefix 'magit-subtree-import "Add subtree") + (let ((remote (magit-read-remote-or-url "From repository"))) + (list remote + (magit-read-refspec "Ref" remote) + (magit-subtree-arguments 'magit-subtree-import))))) + (magit-git-subtree "add" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-add-commit (prefix commit args) + "Add COMMIT as a new subtree at PREFIX." + (interactive + (list (magit-subtree-prefix 'magit-subtree-import "Add subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-import))) + (magit-git-subtree "add" prefix args commit)) + +;;;###autoload +(defun magit-subtree-merge (prefix commit args) + "Merge COMMIT into the PREFIX subtree." + (interactive + (list (magit-subtree-prefix 'magit-subtree-import "Merge into subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-import))) + (magit-git-subtree "merge" prefix args commit)) + +;;;###autoload +(defun magit-subtree-pull (prefix repository ref args) + "Pull REF from REPOSITORY into the PREFIX subtree." + (interactive + (cons (magit-subtree-prefix 'magit-subtree-import "Pull into subtree") + (let ((remote (magit-read-remote-or-url "From repository"))) + (list remote + (magit-read-refspec "Ref" remote) + (magit-subtree-arguments 'magit-subtree-import))))) + (magit-git-subtree "pull" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-push (prefix repository ref args) + "Extract the history of the subtree PREFIX and push it to REF on REPOSITORY." + (interactive (list (magit-subtree-prefix 'magit-subtree-export "Push subtree") + (magit-read-remote-or-url "To repository") + (magit-read-string-ns "To reference") + (magit-subtree-arguments 'magit-subtree-export))) + (magit-git-subtree "push" prefix args repository ref)) + +;;;###autoload +(defun magit-subtree-split (prefix commit args) + "Extract the history of the subtree PREFIX." + (interactive (list (magit-subtree-prefix 'magit-subtree-export "Split subtree") + (magit-read-string-ns "Commit") + (magit-subtree-arguments 'magit-subtree-export))) + (magit-git-subtree "split" prefix args commit)) + +;;; _ +(provide 'magit-subtree) +;;; magit-subtree.el ends here blob - /dev/null blob + 78c87b277ac0b2c068104f806e8ff938130f25a0 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-tag.el @@ -0,0 +1,248 @@ +;;; magit-tag.el --- Tag functionality -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements tag commands. + +;;; Code: + +(require 'magit) + +;; For `magit-tag-delete'. +(defvar helm-comp-read-use-marked) + +;;; Commands + +;;;###autoload (autoload 'magit-tag "magit" nil t) +(transient-define-prefix magit-tag () + "Create or delete a tag." + :man-page "git-tag" + ["Arguments" + ("-f" "Force" ("-f" "--force")) + ("-e" "Edit message" ("-e" "--edit")) + ("-a" "Annotate" ("-a" "--annotate")) + ("-s" "Sign" ("-s" "--sign")) + (magit-tag:--local-user)] + [["Create" + ("t" "tag" magit-tag-create) + ("r" "release" magit-tag-release)] + ["Do" + ("k" "delete" magit-tag-delete) + ("p" "prune" magit-tag-prune)]]) + +(defun magit-tag-arguments () + (transient-args 'magit-tag)) + +(transient-define-argument magit-tag:--local-user () + :description "Sign as" + :class 'transient-option + :shortarg "-u" + :argument "--local-user=" + :reader #'magit-read-gpg-signing-key + :history-key 'magit:--gpg-sign) + +;;;###autoload +(defun magit-tag-create (name rev &optional args) + "Create a new tag with the given NAME at REV. +With a prefix argument annotate the tag. +\n(git tag [--annotate] NAME REV)" + (interactive (list (magit-read-tag "Tag name") + (magit-read-branch-or-commit "Place tag on") + (let ((args (magit-tag-arguments))) + (when current-prefix-arg + (cl-pushnew "--annotate" args :test #'equal)) + args))) + (magit-run-git-with-editor "tag" args name rev)) + +;;;###autoload +(defun magit-tag-delete (tags) + "Delete one or more tags. +If the region marks multiple tags (and nothing else), then offer +to delete those, otherwise prompt for a single tag to be deleted, +defaulting to the tag at point. +\n(git tag -d TAGS)" + (interactive (list (if-let ((tags (magit-region-values 'tag))) + (magit-confirm t nil "Delete %d tags" nil tags) + (let ((helm-comp-read-use-marked t)) + (magit-read-tag "Delete tag" t))))) + (magit-run-git "tag" "-d" tags)) + +;;;###autoload +(defun magit-tag-prune (tags remote-tags remote) + "Offer to delete tags missing locally from REMOTE, and vice versa." + (interactive + (let* ((remote (magit-read-remote "Prune tags using remote")) + (tags (magit-list-tags)) + (rtags (prog2 (message "Determining remote tags...") + (magit-remote-list-tags remote) + (message "Determining remote tags...done"))) + (ltags (cl-set-difference tags rtags :test #'equal)) + (rtags (cl-set-difference rtags tags :test #'equal))) + (unless (or ltags rtags) + (message "Same tags exist locally and remotely")) + (unless (magit-confirm t + "Delete %s locally" + "Delete %d tags locally" + 'noabort ltags) + (setq ltags nil)) + (unless (magit-confirm t + "Delete %s from remote" + "Delete %d tags from remote" + 'noabort rtags) + (setq rtags nil)) + (list ltags rtags remote))) + (when tags + (magit-call-git "tag" "-d" tags)) + (when remote-tags + (magit-run-git-async "push" remote (mapcar (##concat ":" %) remote-tags)))) + +(defvar magit-tag-version-regexp-alist + '(("^[-._+ ]?snapshot\\.?$" . -4) + ("^[-._+]$" . -4) + ("^[-._+ ]?\\(cvs\\|git\\|bzr\\|svn\\|hg\\|darcs\\)\\.?$" . -4) + ("^[-._+ ]?unknown\\.?$" . -4) + ("^[-._+ ]?alpha\\.?$" . -3) + ("^[-._+ ]?beta\\.?$" . -2) + ("^[-._+ ]?\\(pre\\|rc\\)\\.?$" . -1)) + "Overrides `version-regexp-alist' for `magit-tag-release'. +See also `magit-release-tag-regexp'.") + +(defvar magit-release-tag-regexp "\\`\ +\\(?1:\\(?:v\\(?:ersion\\)?\\|r\\(?:elease\\)?\\)[-_]?\\)?\ +\\(?2:[0-9]+\\(?:\\.[0-9]+\\)*\ +\\(?:-[a-zA-Z0-9-]+\\(?:\\.[a-zA-Z0-9-]+\\)*\\)?\\)\\'" + "Regexp used by `magit-tag-release' to parse release tags. + +The first submatch must match the prefix, if any. The second +submatch must match the version string. + +If this matches versions that are not dot separated numbers, +then `magit-tag-version-regexp-alist' has to contain entries +for the separators allowed here.") + +(defvar magit-release-commit-regexp "\\`Release version \\(.+\\)\\'" + "Regexp used by `magit-tag-release' to parse release commit messages. +The first submatch must match the version string.") + +;;;###autoload +(defun magit-tag-release (tag msg &optional args) + "Create a release tag for `HEAD'. + +Assume that release tags match `magit-release-tag-regexp'. + +If `HEAD's message matches `magit-release-commit-regexp', then +base the tag on the version string specified by that. Otherwise +prompt for the name of the new tag using the highest existing +tag as initial input and leaving it to the user to increment the +desired part of the version string. + +When creating an annotated tag, prepare a message based on the message +of the highest existing tag, provided that contains the corresponding +version string, and substituting the new version string for that. If +that is not the case, propose a message using a reasonable format." + (interactive + (save-match-data + (pcase-let* + ((args (magit-tag-arguments)) + (`(,pver ,ptag ,pmsg) (car (magit--list-releases))) + (msg (magit-rev-format "%s")) + (ver (and (string-match magit-release-commit-regexp msg) + (match-string 1 msg))) + (_ (and (not ver) + (require (quote sisyphus) nil t) + (string-match magit-release-commit-regexp + (magit-rev-format "%s" ptag)) + (user-error "Use `sisyphus-create-release' first"))) + (tag (cond + ((not ptag) + ;; Force the user to review the message used for the + ;; initial release tag, in case they do not like the + ;; default format. + (cl-pushnew "--edit" args :test #'equal) + (read-string "Create first release tag: " + (if (and ver (string-match-p "\\`[0-9]" ver)) + (concat "v" ver) + ver))) + (ver + (concat (and (string-match magit-release-tag-regexp ptag) + (match-string 1 ptag)) + ver)) + (t + (read-string + (format "Create release tag (previous was %s): " ptag) + ptag)))) + (ver (and (string-match magit-release-tag-regexp tag) + (match-string 2 tag)))) + (list tag + (and (seq-some (apply-partially + #'string-match-p + "\\`--\\(annotate\\|local-user\\|sign\\)") + args) + (cond ((and pver (string-match (regexp-quote pver) pmsg)) + (replace-match ver t t pmsg)) + ((and ptag (string-match (regexp-quote ptag) pmsg)) + (replace-match tag t t pmsg)) + ((format "%s %s" + (capitalize + (file-name-nondirectory + (directory-file-name (magit-toplevel)))) + ver)))) + args)))) + (magit-run-git-with-editor "tag" args (and msg (list "-m" msg)) tag) + (set-process-sentinel + magit-this-process + (lambda (process event) + (when (memq (process-status process) '(exit signal)) + (magit-process-sentinel process event) + (magit-refs-setup-buffer "HEAD" (magit-show-refs-arguments)))))) + +(defun magit--list-releases () + "Return a list of releases. +The list is ordered, beginning with the highest release. +Each release element has the form (VERSION TAG MESSAGE). +`magit-release-tag-regexp' is used to determine whether +a tag qualifies as a release tag." + (save-match-data + (mapcar + #'cdr + (nreverse + (cl-sort (mapcan + (lambda (line) + (and (string-match " +" line) + (let ((tag (substring line 0 (match-beginning 0))) + (msg (substring line (match-end 0)))) + (and (string-match magit-release-tag-regexp tag) + (let ((ver (match-string 2 tag)) + (version-regexp-alist + magit-tag-version-regexp-alist)) + (list (list (version-to-list ver) + ver tag msg))))))) + ;; Cannot rely on "--sort=-version:refname" because + ;; that gets confused if the version prefix has changed. + (magit-git-lines "tag" "-n")) + ;; The inverse of this function does not exist. + #'version-list-< :key #'car))))) + +;;; _ +(provide 'magit-tag) +;;; magit-tag.el ends here blob - /dev/null blob + 7ebd10cd3c8d9d824bd8f2d977a7f3e1c8011a9d (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-transient.el @@ -0,0 +1,243 @@ +;;; magit-transient.el --- Support for transients -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements Magit-specific prefix and suffix classes, +;; and their methods. + +;;; Code: + +(require 'magit-git) +(require 'magit-mode) +(require 'magit-process) + +(require 'transient) + +;;; Classes + +(defclass magit--git-variable (transient-variable) + ((scope :initarg :scope) + (global :initarg :global :initform nil) + (default :initarg :default :initform nil))) + +(defclass magit--git-variable:choices (magit--git-variable) + ((choices :initarg :choices) + (fallback :initarg :fallback :initform nil))) + +(defclass magit--git-variable:boolean (magit--git-variable:choices) + ((choices :initarg :choices :initform '("true" "false")))) + +(defclass magit--git-variable:urls (magit--git-variable) + ((seturl-arg :initarg :seturl-arg :initform nil))) + +;;; Methods +;;;; Init + +(cl-defmethod transient-init-scope ((obj magit--git-variable)) + (oset obj scope + (cond (transient--prefix + (oref transient--prefix scope)) + ((slot-boundp obj 'scope) + (funcall (oref obj scope) obj))))) + +(cl-defmethod transient-init-value ((obj magit--git-variable)) + (let ((variable (format (oref obj variable) + (oref obj scope))) + (arg (if (oref obj global) "--global" "--local"))) + (oset obj variable variable) + (oset obj value + (cond ((oref obj multi-value) + (magit-get-all arg variable)) + (t + (magit-get arg variable)))))) + +(cl-defmethod transient-init-value ((obj magit--git-variable:boolean)) + (let ((variable (format (oref obj variable) + (oref obj scope))) + (arg (if (oref obj global) "--global" "--local"))) + (oset obj variable variable) + (oset obj value (if (magit-get-boolean arg variable) "true" "false")))) + +;;;; Read + +(cl-defmethod transient-infix-read :around ((obj magit--git-variable:urls)) + (transient--with-emergency-exit + (transient--with-suspended-override + (mapcar (lambda (url) + (if (string-prefix-p "~" url) + (expand-file-name url) + url)) + (cl-call-next-method obj))))) + +(cl-defmethod transient-infix-read ((obj magit--git-variable:choices)) + (let ((choices (oref obj choices))) + (when (functionp choices) + (setq choices (funcall choices))) + (if current-prefix-arg + (pcase-let* + ((`(,fallback . ,choices) + (magit--git-variable-list-choices obj)) + (choice (magit-completing-read + (format "Set `%s' to" (oref obj variable)) + (if fallback (nconc choices (list fallback)) choices) + nil t))) + (if (equal choice fallback) nil choice)) + (if-let ((value (oref obj value))) + (cadr (member value choices)) + (car choices))))) + +;;;; Readers + +(defun magit-transient-read-person (prompt initial-input history) + (magit-completing-read + prompt + (mapcar (##save-excursion + (and (string-match "\\`[\s\t]+[0-9]+\t" %) + (list (substring % (match-end 0))))) + (magit-git-lines "shortlog" "-n" "-s" "-e" "HEAD")) + nil nil initial-input history)) + +(defun magit-transient-read-revision (prompt initial-input history) + (or (magit-completing-read prompt (cons "HEAD" (magit-list-refnames)) + nil nil initial-input history + (or (magit-branch-or-commit-at-point) + (magit-get-current-branch))) + (user-error "Nothing selected"))) + +;;;; Set + +(cl-defmethod transient-infix-set ((obj magit--git-variable) value) + (let ((variable (oref obj variable)) + (arg (if (oref obj global) "--global" "--local"))) + (oset obj value value) + (if (oref obj multi-value) + (magit-set-all value arg variable) + (magit-set value arg variable)) + (magit-refresh) + (unless (or value transient--prefix) + (message "Unset %s" variable)))) + +(cl-defmethod transient-infix-set ((obj magit--git-variable:urls) values) + (let ((previous (oref obj value)) + (seturl (oref obj seturl-arg)) + (remote (oref transient--prefix scope))) + (oset obj value values) + (dolist (v (cl-set-difference values previous :test #'equal)) + (magit-call-git "remote" "set-url" seturl "--add" remote v)) + (dolist (v (cl-set-difference previous values :test #'equal)) + (magit-call-git "remote" "set-url" seturl "--delete" remote + (concat "^" (regexp-quote v) "$"))) + (magit-refresh))) + +;;;; Draw + +(cl-defmethod transient-format-description ((obj magit--git-variable)) + (or (oref obj description) + (oref obj variable))) + +(cl-defmethod transient-format-value ((obj magit--git-variable)) + (if-let ((value (oref obj value))) + (if (oref obj multi-value) + (if (cdr value) + (mapconcat (##concat "\n " + (propertize % 'face 'transient-value)) + value "") + (propertize (car value) 'face 'transient-value)) + (propertize (car (split-string value "\n")) + 'face 'transient-value)) + (if-let* ((default (oref obj default)) + (default (if (functionp default) (funcall default) default))) + (concat (propertize "default:" 'face 'transient-inactive-value) + (propertize default 'face 'transient-value)) + (propertize "unset" 'face 'transient-inactive-value)))) + +(cl-defmethod transient-format-value ((obj magit--git-variable:choices)) + (pcase-let ((`(,fallback . ,choices) (magit--git-variable-list-choices obj))) + (concat + (propertize "[" 'face 'transient-inactive-value) + (mapconcat #'identity choices + (propertize "|" 'face 'transient-inactive-value)) + (and fallback (propertize "|" 'face 'transient-inactive-value)) + fallback + (propertize "]" 'face 'transient-inactive-value)))) + +(defun magit--git-variable-list-choices (obj) + (let* ((variable (oref obj variable)) + (choices (oref obj choices)) + (globalp (oref obj global)) + (value nil) + (global (magit-git-string "config" "--global" variable)) + (defaultp (oref obj default)) + (default (if (functionp defaultp) (funcall defaultp obj) defaultp)) + (fallback (oref obj fallback)) + (fallback (and fallback + (and-let* ((val (magit-get fallback))) + (concat fallback ":" val))))) + (if (not globalp) + (setq value (magit-git-string "config" "--local" variable)) + (setq value global) + (setq global nil)) + (when (functionp choices) + (setq choices (funcall choices))) + (cons (cond (global + (propertize (concat "global:" global) + 'face (cond (value + 'transient-inactive-value) + ((member global choices) + 'transient-value) + (t + 'font-lock-warning-face)))) + (fallback + (propertize fallback + 'face (if value + 'transient-inactive-value + 'transient-value))) + (default + (propertize (if (functionp defaultp) + (concat "dwim:" default) + (concat "default:" default)) + 'face (if value + 'transient-inactive-value + 'transient-value)))) + (mapcar (lambda (choice) + (propertize choice 'face (if (equal choice value) + (if (member choice choices) + 'transient-value + 'font-lock-warning-face) + 'transient-inactive-value))) + (if (and value (not (member value choices))) + (cons value choices) + choices))))) + +;;; Utilities + +(defun magit--transient-args-and-files () + "Return (args files) for use by log and diff functions. +The value derives from that returned by `transient-get-value'." + (let ((args (transient-get-value))) + (list (seq-filter #'atom args) + (cdr (assoc "--" args))))) + +;;; _ +(provide 'magit-transient) +;;; magit-transient.el ends here blob - /dev/null blob + 712b784527529143e723944c10f248496e535aaa (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-wip.el @@ -0,0 +1,461 @@ +;;; magit-wip.el --- Commit snapshots to work-in-progress refs -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library defines tree global modes which automatically commit +;; snapshots to branch-specific work-in-progress refs before and after +;; making changes, and two commands which can be used to do so on +;; demand. + +;;; Code: + +(require 'magit-core) +(require 'magit-log) + +;;; Options + +(defgroup magit-wip nil + "Automatically commit to work-in-progress refs." + :link '(info-link "(magit)Wip Modes") + :group 'magit-modes + :group 'magit-essentials) + +(defcustom magit-wip-mode-lighter " Wip" + "Lighter for Magit-Wip mode." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :type 'string) + +(defcustom magit-wip-merge-branch nil + "Whether to merge the current branch into its wip ref. + +If non-nil and the current branch has new commits, then it is +merged into the wip ref before creating a new wip commit. This +makes it easier to inspect wip history and the wip commits are +never garbage collected. + +If nil and the current branch has new commits, then the wip ref +is reset to the tip of the branch before creating a new wip +commit. With this setting wip commits are eventually garbage +collected. This is currently the default." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :type 'boolean) + +(defcustom magit-wip-namespace "refs/wip/" + "Namespace used for work-in-progress refs. +The wip refs are named \"index/\" +and \"wtree/\". When snapshots +are created while the `HEAD' is detached then \"HEAD\" +is used as `branch-ref'." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :type 'string) + +;;; Modes + +(defvar magit--wip-activation-cache nil) +(defvar magit--wip-inhibit-autosave nil) + +;;;###autoload +(define-minor-mode magit-wip-mode + "Save uncommitted changes to work-in-progress refs. + +Whenever appropriate (i.e., when dataloss would be a possibility +otherwise) this mode causes uncommitted changes to be committed +to dedicated work-in-progress refs. + +For historic reasons this mode is implemented on top of four +other `magit-wip-*' modes, which can also be used individually, +if you want finer control over when the wip refs are updated; +but that is discouraged." + :package-version '(magit . "2.90.0") + :lighter magit-wip-mode-lighter + :global t + (let ((arg (if magit-wip-mode 1 -1))) + (let ((magit--wip-activation-cache (list t))) + (magit-wip-after-save-mode arg)) + (magit-wip-after-apply-mode arg) + (magit-wip-before-change-mode arg) + (magit-wip-initial-backup-mode arg))) + +(define-minor-mode magit-wip-after-save-local-mode + "After saving, also commit to a worktree work-in-progress ref. + +After saving the current file-visiting buffer this mode also +commits the changes to the worktree work-in-progress ref for +the current branch. + +This mode should be enabled globally by turning on the globalized +variant `magit-wip-after-save-mode'." + :package-version '(magit . "2.1.0") + (if magit-wip-after-save-local-mode + (if (and buffer-file-name (magit-inside-worktree-p t)) + (add-hook 'after-save-hook #'magit-wip-commit-buffer-file t t) + (setq magit-wip-after-save-local-mode nil) + (user-error "Need a worktree and a file")) + (remove-hook 'after-save-hook #'magit-wip-commit-buffer-file t))) + +(defun magit-wip-after-save-local-mode-turn-on () + (when (and buffer-file-name + (if magit--wip-activation-cache + (if-let ((elt (assoc default-directory + magit--wip-activation-cache))) + (and-let* ((top (cadr elt))) + (member (file-relative-name buffer-file-name top) + (cddr elt))) + (if-let ((top (magit-toplevel))) + (let (files) + (if-let ((elt (assoc top magit--wip-activation-cache))) + (setq files (cddr elt)) + (setq files (let ((default-directory top)) + (magit-tracked-files))) + (push `(,top ,top ,@files) + magit--wip-activation-cache) + (unless (eq default-directory top) + (push `(,default-directory ,top ,@files) + magit--wip-activation-cache))) + (member (file-relative-name buffer-file-name) files)) + (push (list default-directory nil) + magit--wip-activation-cache) + nil)) + (and (magit-inside-worktree-p t) + (magit-file-tracked-p buffer-file-name)))) + (magit-wip-after-save-local-mode))) + +;;;###autoload +(define-globalized-minor-mode magit-wip-after-save-mode + magit-wip-after-save-local-mode magit-wip-after-save-local-mode-turn-on + :package-version '(magit . "2.1.0") + :group 'magit-wip) + +(defun magit-wip-commit-buffer-file (&optional msg) + "Commit visited file to a worktree work-in-progress ref. + +Also see `magit-wip-after-save-mode' which calls this function +automatically whenever a buffer visiting a tracked file is saved." + (interactive (list "wip-save %s after save")) + (when-let (((not magit--wip-inhibit-autosave)) + (ref (magit-wip-get-ref))) + (magit-with-toplevel + (let ((file (file-relative-name buffer-file-name))) + (magit-wip-commit-worktree + ref (list file) + (format (or msg "autosave %s after save") file)))))) + +;;;###autoload +(define-minor-mode magit-wip-after-apply-mode + "Commit to work-in-progress refs. + +After applying a change using any \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected files to the current wip refs. For each branch there +may be two wip refs; one contains snapshots of the files as found +in the worktree and the other contains snapshots of the entries +in the index." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :global t) + +(defun magit-wip-commit-after-apply (&optional files msg) + (when magit-wip-after-apply-mode + (magit-wip-commit files msg))) + +;;;###autoload +(define-minor-mode magit-wip-before-change-mode + "Commit to work-in-progress refs before certain destructive changes. + +Before invoking a revert command or an \"apply variant\" +command (apply, stage, unstage, discard, and reverse) commit the +affected tracked files to the current wip refs. For each branch +there may be two wip refs; one contains snapshots of the files +as found in the worktree and the other contains snapshots of the +entries in the index. + +Only changes to files which could potentially be affected by the +command which is about to be called are committed." + :package-version '(magit . "2.1.0") + :group 'magit-wip + :global t) + +(defun magit-wip-commit-before-change (&optional files msg) + (when magit-wip-before-change-mode + (magit-with-toplevel + (magit-wip-commit files msg)))) + +(define-minor-mode magit-wip-initial-backup-mode + "Before saving a buffer for the first time, commit to a wip ref." + :package-version '(magit . "2.90.0") + :group 'magit-wip + :global t + (if magit-wip-initial-backup-mode + (add-hook 'before-save-hook #'magit-wip-commit-initial-backup) + (remove-hook 'before-save-hook #'magit-wip-commit-initial-backup))) + +(defun magit--any-wip-mode-enabled-p () + "Return non-nil if any global wip mode is enabled." + (or magit-wip-mode + magit-wip-after-save-mode + magit-wip-after-apply-mode + magit-wip-before-change-mode + magit-wip-initial-backup-mode)) + +(defvar-local magit-wip-buffer-backed-up nil) +(put 'magit-wip-buffer-backed-up 'permanent-local t) + +;;;###autoload +(defun magit-wip-commit-initial-backup () + "Before saving, commit current file to a worktree wip ref. + +The user has to add this function to `before-save-hook'. + +Commit the current state of the visited file before saving the +current buffer to that file. This backs up the same version of +the file as `backup-buffer' would, but stores the backup in the +worktree wip ref, which is also used by the various Magit Wip +modes, instead of in a backup file as `backup-buffer' would. + +This function ignores the variables that affect `backup-buffer' +and can be used along-side that function, which is recommended +because this function only backs up files that are tracked in +a Git repository." + (when (and (not magit-wip-buffer-backed-up) + buffer-file-name + (magit-inside-worktree-p t) + (magit-file-tracked-p buffer-file-name)) + (let ((magit-save-repository-buffers nil)) + (magit-wip-commit-buffer-file "autosave %s before save")) + (setq magit-wip-buffer-backed-up t))) + +;;; Core + +(defun magit-wip-commit (&optional files msg) + "Commit all tracked files to the work-in-progress refs. + +Interactively, commit all changes to all tracked files using +a generic commit message. With a prefix-argument the commit +message is read in the minibuffer. + +Non-interactively, only commit changes to FILES using MSG as +commit message." + (interactive (list nil (if current-prefix-arg + (magit-read-string "Wip commit message") + "wip-save tracked files"))) + (when-let ((ref (magit-wip-get-ref))) + (magit-wip-commit-index ref files msg) + (magit-wip-commit-worktree ref files msg))) + +(defun magit-wip-commit-index (ref files msg) + (let* ((wipref (magit--wip-index-ref ref)) + (parent (magit-wip-get-parent ref wipref)) + (tree (magit-git-string "write-tree"))) + (magit-wip-update-wipref ref wipref tree parent files msg "index"))) + +(defun magit-wip-commit-worktree (ref files msg) + (when (or (not files) + ;; `update-index' will either ignore (before Git v2.32.0) + ;; or fail when passed directories (relevant for the + ;; untracked files code paths). + (setq files (seq-remove #'file-directory-p files))) + (let* ((wipref (magit--wip-wtree-ref ref)) + (parent (magit-wip-get-parent ref wipref)) + (tree (magit-with-temp-index parent (list "--reset" "-i") + (if files + ;; Note: `update-index' is used instead of `add' + ;; because `add' will fail if a file is already + ;; deleted in the temporary index. + (magit-call-git "update-index" "--add" "--remove" + "--ignore-skip-worktree-entries" + "--" files) + (magit-with-toplevel + (magit-call-git "add" "-u" "."))) + (magit-git-string "write-tree")))) + (magit-wip-update-wipref ref wipref tree parent files msg "worktree")))) + +(defun magit-wip-update-wipref (ref wipref tree parent files msg start-msg) + (cond + ((and (not (equal parent wipref)) + (or (not magit-wip-merge-branch) + (not (magit-rev-verify wipref)))) + (setq start-msg (concat "start autosaving " start-msg)) + (magit-update-ref wipref start-msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" parent "-m" start-msg + (concat parent "^{tree}"))) + (setq parent wipref)) + ((and magit-wip-merge-branch + (or (not (magit-rev-ancestor-p ref wipref)) + (not (magit-rev-ancestor-p + (concat (magit-git-string "log" "--format=%H" + "-1" "--merges" wipref) + "^2") + ref)))) + (setq start-msg (format "merge %s into %s" ref start-msg)) + (magit-update-ref wipref start-msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" wipref "-p" ref + "-m" start-msg + (concat ref "^{tree}"))) + (setq parent wipref))) + (when (magit-git-failure "diff-tree" "--quiet" parent tree "--" files) + (unless (and msg (not (= (aref msg 0) ?\s))) + (let ((len (length files))) + (setq msg (concat + (cond ((= len 0) "autosave tracked files") + ((> len 1) (format "autosave %s files" len)) + ((concat "autosave " + (file-relative-name (car files) + (magit-toplevel))))) + msg)))) + (magit-update-ref wipref msg + (magit-git-string "commit-tree" "--no-gpg-sign" + "-p" parent "-m" msg tree)))) + +(defun magit-wip-get-ref () + (let ((ref (or (magit-git-string "symbolic-ref" "HEAD") "HEAD"))) + (and (magit-rev-verify ref) + ref))) + +(defun magit-wip-get-parent (ref wipref) + (if (and (magit-rev-verify wipref) + (equal (magit-git-string "merge-base" wipref ref) + (magit-rev-verify ref))) + wipref + ref)) + +(defun magit--wip-index-ref (&optional ref) + (magit--wip-ref "index/" ref)) + +(defun magit--wip-wtree-ref (&optional ref) + (magit--wip-ref "wtree/" ref)) + +(defun magit--wip-ref (namespace &optional ref) + (concat magit-wip-namespace namespace + (or (and ref (string-prefix-p "refs/" ref) ref) + (and-let* ((branch (and (not (equal ref "HEAD")) + (or ref (magit-get-current-branch))))) + (concat "refs/heads/" branch)) + "HEAD"))) + +(defun magit-wip-maybe-add-commit-hook () + (when (and magit-wip-merge-branch + (magit-wip-any-enabled-p)) + (add-hook 'git-commit-post-finish-hook #'magit-wip-commit nil t))) + +(defun magit-wip-any-enabled-p () + (or magit-wip-mode + magit-wip-after-save-local-mode + magit-wip-after-save-mode + magit-wip-after-apply-mode + magit-wip-before-change-mode + magit-wip-initial-backup-mode)) + +;;; Log + +(defun magit-wip-log-index (args files) + "Show log for the index wip ref of the current branch." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list (magit--wip-index-ref)) args files)) + +(defun magit-wip-log-worktree (args files) + "Show log for the worktree wip ref of the current branch." + (interactive (magit-log-arguments)) + (magit-log-setup-buffer (list (magit--wip-wtree-ref)) args files)) + +(defun magit-wip-log-current (branch args files count) + "Show log for the current branch and its wip refs. +With a negative prefix argument only show the worktree wip ref. +The absolute numeric value of the prefix argument controls how +many \"branches\" of each wip ref are shown." + (interactive + (nconc (list (or (magit-get-current-branch) "HEAD")) + (magit-log-arguments) + (list (prefix-numeric-value current-prefix-arg)))) + (magit-wip-log branch args files count)) + +(defun magit-wip-log (branch args files count) + "Show log for a branch and its wip refs. +With a negative prefix argument only show the worktree wip ref. +The absolute numeric value of the prefix argument controls how +many \"branches\" of each wip ref are shown." + (interactive + (nconc (list (magit-completing-read + "Log branch and its wip refs" + (nconc (magit-list-local-branch-names) + (list "HEAD")) + nil t nil 'magit-revision-history + (or (magit-branch-at-point) + (magit-get-current-branch) + "HEAD"))) + (magit-log-arguments) + (list (prefix-numeric-value current-prefix-arg)))) + (magit-log-setup-buffer (nconc (list branch) + (magit-wip-log-get-tips + (magit--wip-wtree-ref branch) + (abs count)) + (and (>= count 0) + (magit-wip-log-get-tips + (magit--wip-index-ref branch) + (abs count)))) + args files)) + +(defun magit-wip-log-get-tips (wipref count) + (and-let* ((reflog (magit-git-lines "reflog" wipref))) + (let (tips) + (while (and reflog (> count 1)) + ;; "start autosaving ..." is the current message, but it used + ;; to be "restart autosaving ...", and those messages may + ;; still be around (e.g., if gc.reflogExpire is set to "never"). + (setq reflog (cl-member "^[^ ]+ [^:]+: \\(?:re\\)?start autosaving" + reflog :test #'string-match-p)) + (when (and (cadr reflog) + (string-match "^[^ ]+ \\([^:]+\\)" (cadr reflog))) + (push (match-string 1 (cadr reflog)) tips)) + (setq reflog (cddr reflog)) + (cl-decf count)) + (cons wipref (nreverse tips))))) + +(defun magit-wip-purge () + "Ask to delete all wip-refs that no longer have a corresponding ref." + (interactive) + (if-let ((wiprefs (thread-last + (cl-set-difference (magit-list-refs "refs/wip/") + (magit-list-refs) + :test (##equal (substring %1 15) %2)) + (delete "refs/wip/index/HEAD") + (delete "refs/wip/wtree/HEAD")))) + (progn + (magit-confirm 'purge-dangling-wiprefs + "Delete wip-ref %s without corresponding ref" + "Delete %d wip-refs without corresponding ref" + nil wiprefs) + (message "Deleting wip-refs...") + (dolist (wipref wiprefs) + (magit-call-git "update-ref" "-d" wipref)) + (message "Deleting wip-refs...done") + (magit-refresh)) + (message "All wip-refs have a corresponding ref"))) + +;;; _ +(provide 'magit-wip) +;;; magit-wip.el ends here blob - /dev/null blob + f38cad5213a02f9235da9d0ad470d545064b8f0b (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit-worktree.el @@ -0,0 +1,207 @@ +;;; magit-worktree.el --- Worktree support -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for `git-worktree'. + +;;; Code: + +(require 'magit) + +;;; Options + +(defcustom magit-worktree-read-directory-name-function #'read-directory-name + "Function used to read a directory for worktree commands. +This is called with one argument, the prompt, and can be used +to, e.g., use a base directory other than `default-directory'. +Used by `magit-worktree-checkout' and `magit-worktree-branch'." + :package-version '(magit . "3.0.0") + :group 'magit-commands + :type 'function) + +;;; Commands + +;;;###autoload (autoload 'magit-worktree "magit-worktree" nil t) +(transient-define-prefix magit-worktree () + "Act on a worktree." + :man-page "git-worktree" + [["Create new" + ("b" "worktree" magit-worktree-checkout) + ("c" "branch and worktree" magit-worktree-branch)] + ["Commands" + ("m" "Move worktree" magit-worktree-move) + ("k" "Delete worktree" magit-worktree-delete) + ("g" "Visit worktree" magit-worktree-status)]]) + +;;;###autoload +(defun magit-worktree-checkout (path branch) + "Checkout BRANCH in a new worktree at PATH." + (interactive + (let ((branch (magit-read-branch-or-commit "Checkout"))) + (list (funcall magit-worktree-read-directory-name-function + (format "Checkout %s in new worktree: " branch)) + branch))) + (when (zerop (magit-run-git "worktree" "add" + (magit--expand-worktree path) branch)) + (magit-diff-visit-directory path))) + +;;;###autoload +(defun magit-worktree-branch (path branch start-point) + "Create a new BRANCH and check it out in a new worktree at PATH." + (interactive + `(,(funcall magit-worktree-read-directory-name-function + "Create worktree: ") + ,@(magit-branch-read-args "Create and checkout branch"))) + (when (zerop (magit-run-git "worktree" "add" "-b" branch + (magit--expand-worktree path) start-point)) + (magit-diff-visit-directory path))) + +;;;###autoload +(defun magit-worktree-move (worktree path) + "Move WORKTREE to PATH." + (interactive + (list (magit-completing-read "Move worktree" + (cdr (magit-list-worktrees)) + nil t nil nil + (magit-section-value-if 'worktree)) + (funcall magit-worktree-read-directory-name-function + "Move worktree to: "))) + (if (file-directory-p (expand-file-name ".git" worktree)) + (user-error "You may not move the main working tree") + (let ((preexisting-directory (file-directory-p path))) + (when (and (zerop (magit-call-git "worktree" "move" worktree + (magit--expand-worktree path))) + (not (file-exists-p default-directory)) + (derived-mode-p 'magit-status-mode)) + (kill-buffer) + (magit-diff-visit-directory + (if preexisting-directory + (concat (file-name-as-directory path) + (file-name-nondirectory worktree)) + path))) + (magit-refresh)))) + +(defun magit-worktree-delete (worktree) + "Delete a worktree, defaulting to the worktree at point. +The primary worktree cannot be deleted." + (interactive + (list (magit-completing-read "Delete worktree" + (cdr (magit-list-worktrees)) + nil t nil nil + (magit-section-value-if 'worktree)))) + (if (file-directory-p (expand-file-name ".git" worktree)) + (user-error "Deleting %s would delete the shared .git directory" worktree) + (let ((primary (file-name-as-directory (caar (magit-list-worktrees))))) + (magit-confirm-files (if magit-delete-by-moving-to-trash 'trash 'delete) + (list worktree)) + (when (file-exists-p worktree) + (let ((delete-by-moving-to-trash magit-delete-by-moving-to-trash)) + (delete-directory worktree t magit-delete-by-moving-to-trash))) + (if (file-exists-p default-directory) + (magit-run-git "worktree" "prune") + (let ((default-directory primary)) + (magit-run-git "worktree" "prune")) + (when (derived-mode-p 'magit-status-mode) + (kill-buffer) + (magit-status-setup-buffer primary)))))) + +(defun magit-worktree-status (worktree) + "Show the status for the worktree at point. +If there is no worktree at point, then read one in the +minibuffer. If the worktree at point is the one whose +status is already being displayed in the current buffer, +then show it in Dired instead." + (interactive + (list (or (magit-section-value-if 'worktree) + (magit-completing-read + "Show status for worktree" + (cl-delete (directory-file-name (magit-toplevel)) + (magit-list-worktrees) + :test #'equal :key #'car))))) + (magit-diff-visit-directory worktree)) + +(defun magit--expand-worktree (path) + (magit-convert-filename-for-git (expand-file-name path))) + +;;; Sections + +(defvar-keymap magit-worktree-section-map + :doc "Keymap for `worktree' sections." + " " #'magit-worktree-delete + " " #'magit-worktree-status + "<4>" (magit-menu-item "Worktree commands..." #'magit-worktree) + "<3>" '(menu-item "--") + "<2>" (magit-menu-item "Delete %m" #'magit-worktree-delete) + "<1>" (magit-menu-item "Visit %s" #'magit-worktree-status)) + +(defun magit-insert-worktrees () + "Insert sections for all worktrees. +If there is only one worktree, then insert nothing." + (let ((worktrees (magit-list-worktrees))) + (when (length> worktrees 1) + (magit-insert-section (worktrees) + (magit-insert-heading t "Worktrees") + (let* ((cols + (mapcar + (lambda (config) + (pcase-let ((`(,_ ,commit ,branch ,bare) config)) + (cons (cond + (branch + (propertize + branch 'font-lock-face + (if (equal branch (magit-get-current-branch)) + 'magit-branch-current + 'magit-branch-local))) + (commit + (propertize (magit-rev-abbrev commit) + 'font-lock-face 'magit-hash)) + (bare "(bare)")) + config))) + worktrees)) + (align (1+ (apply #'max (mapcar (##string-width (car %)) cols))))) + (pcase-dolist (`(,head . ,config) cols) + (magit--insert-worktree + config + (concat head (make-string (- align (length head)) ?\s))))) + (insert ?\n))))) + +(defun magit--insert-worktree (config head) + "Insert worktree section for CONFIG. +See `magit-list-worktrees' for the format of CONFIG. HEAD is +a prettified reference or revision representing the worktree, +with padding for alignment." + ;; #4926 Before changing the signature, inform @vermiculus. + (let ((path (car config))) + (magit-insert-section (worktree path) + (insert head) + (insert (let ((relative (file-relative-name path)) + (absolute (abbreviate-file-name path))) + (if (or (> (string-width relative) (string-width absolute)) + (equal relative "./")) + absolute + relative))) + (insert ?\n)))) + +;;; _ +(provide 'magit-worktree) +;;; magit-worktree.el ends here blob - /dev/null blob + a65314e1b223b17f6d7a537b431042fd8f1eefc9 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit.el @@ -0,0 +1,799 @@ +;;; magit.el --- A Git porcelain inside Emacs -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Marius Vollmer +;; Jonas Bernoulli +;; Maintainer: Jonas Bernoulli +;; Kyle Meyer +;; Former-Maintainers: +;; Nicolas Dudebout +;; Noam Postavsky +;; Peter J. Weisberg +;; Phil Jackson +;; Rémi Vanicat +;; Yann Hodique + +;; Homepage: https://github.com/magit/magit +;; Keywords: git tools vc + +;; Package-Version: 4.3.8 +;; Package-Requires: ( +;; (emacs "27.1") +;; (compat "30.1") +;; (llama "1.0.0") +;; (magit-section "4.3.8") +;; (seq "2.24") +;; (transient "0.9.3") +;; (with-editor "3.4.4")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, +;; or (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;; You should have received a copy of the AUTHORS.md file, which +;; lists all contributors. If not, see https://magit.vc/authors. + +;;; Commentary: + +;; Magit is a text-based Git user interface that puts an unmatched focus +;; on streamlining workflows. Commands are invoked using short mnemonic +;; key sequences that take the cursor’s position in the highly actionable +;; interface into account to provide context-sensitive behavior. + +;; With Magit you can do nearly everything that you can do when using Git +;; on the command-line, but at greater speed and while taking advantage +;; of advanced features that previously seemed too daunting to use on a +;; daily basis. Many users will find that by using Magit they can become +;; more effective Git user. + +;;; Code: + +(require 'magit-core) +(require 'magit-diff) +(require 'magit-log) +(require 'magit-wip) +(require 'magit-apply) +(require 'magit-repos) +(require 'git-commit) + +(require 'format-spec) +(require 'package nil t) ; used in `magit-version' +(require 'with-editor) + +;; For `magit:--gpg-sign' +(declare-function epg-list-keys "epg" (context &optional name mode)) +(declare-function epg-decode-dn "epg" (alist)) +(defvar epa-protocol) + +;;; Options + +(defcustom magit-openpgp-default-signing-key nil + "Fingerprint of your default Openpgp key used for signing. +If the specified primary key has signing capacity then it is used +as the value of the `--gpg-sign' argument without prompting, even +when other such keys exist. To be able to select another key you +must then use a prefix argument." + :package-version '(magit . "4.0.0") + :group 'magit-commands + :type 'string) + +;;; Faces + +(defface magit-header-line + '((t :inherit magit-section-heading)) + "Face for the `header-line' in some Magit modes. +Note that some modes, such as `magit-log-select-mode', have their +own faces for the `header-line', or for parts of the +`header-line'." + :group 'magit-faces) + +(defface magit-header-line-key + '((t :inherit font-lock-builtin-face)) + "Face for keys in the `header-line'." + :group 'magit-faces) + +(defface magit-dimmed + '((((class color) (background light)) :foreground "grey50") + (((class color) (background dark)) :foreground "grey50")) + "Face for text that shouldn't stand out." + :group 'magit-faces) + +(defface magit-hash + '((((class color) (background light)) :foreground "grey60") + (((class color) (background dark)) :foreground "grey40")) + "Face for the commit object name in the log output." + :group 'magit-faces) + +(defface magit-tag + '((((class color) (background light)) :foreground "Goldenrod4") + (((class color) (background dark)) :foreground "LightGoldenrod2")) + "Face for tag labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote + '((((class color) (background light)) :foreground "DarkOliveGreen4") + (((class color) (background dark)) :foreground "DarkSeaGreen2")) + "Face for remote branch head labels shown in log buffer." + :group 'magit-faces) + +(defface magit-branch-remote-head + '((((supports (:box t))) :inherit magit-branch-remote :box t) + (t :inherit magit-branch-remote :inverse-video t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-local + '((((class color) (background light)) :foreground "SkyBlue4") + (((class color) (background dark)) :foreground "LightSkyBlue1")) + "Face for local branches." + :group 'magit-faces) + +(defface magit-branch-current + '((((supports (:box t))) :inherit magit-branch-local :box t) + (t :inherit magit-branch-local :inverse-video t)) + "Face for current branch." + :group 'magit-faces) + +(defface magit-branch-upstream + '((t :slant italic)) + "Face for upstream branch. +This face is only used in logs and it gets combined + with `magit-branch-local', `magit-branch-remote' +and/or `magit-branch-remote-head'." + :group 'magit-faces) + +(defface magit-branch-warning + '((t :inherit warning)) + "Face for warning about (missing) branch." + :group 'magit-faces) + +(defface magit-head + '((((class color) (background light)) :inherit magit-branch-local) + (((class color) (background dark)) :inherit magit-branch-local)) + "Face for the symbolic ref `HEAD'." + :group 'magit-faces) + +(defface magit-refname + '((((class color) (background light)) :foreground "grey30") + (((class color) (background dark)) :foreground "grey80")) + "Face for refnames without a dedicated face." + :group 'magit-faces) + +(defface magit-refname-stash + '((t :inherit magit-refname)) + "Face for stash refnames." + :group 'magit-faces) + +(defface magit-refname-wip + '((t :inherit magit-refname)) + "Face for wip refnames." + :group 'magit-faces) + +(defface magit-refname-pullreq + '((t :inherit magit-refname)) + "Face for pullreq refnames." + :group 'magit-faces) + +(defface magit-keyword + '((t :inherit font-lock-string-face)) + "Face for parts of commit messages inside brackets." + :group 'magit-faces) + +(defface magit-keyword-squash + '((t :inherit font-lock-warning-face)) + "Face for squash! and similar keywords in commit messages." + :group 'magit-faces) + +(defface magit-signature-good + '((t :foreground "green")) + "Face for good signatures." + :group 'magit-faces) + +(defface magit-signature-bad + '((t :foreground "red" :weight bold)) + "Face for bad signatures." + :group 'magit-faces) + +(defface magit-signature-untrusted + '((t :foreground "medium aquamarine")) + "Face for good untrusted signatures." + :group 'magit-faces) + +(defface magit-signature-expired + '((t :foreground "orange")) + "Face for signatures that have expired." + :group 'magit-faces) + +(defface magit-signature-expired-key + '((t :inherit magit-signature-expired)) + "Face for signatures made by an expired key." + :group 'magit-faces) + +(defface magit-signature-revoked + '((t :foreground "violet red")) + "Face for signatures made by a revoked key." + :group 'magit-faces) + +(defface magit-signature-error + '((t :foreground "light blue")) + "Face for signatures that cannot be checked (e.g., missing key)." + :group 'magit-faces) + +(defface magit-cherry-unmatched + '((t :foreground "cyan")) + "Face for unmatched cherry commits." + :group 'magit-faces) + +(defface magit-cherry-equivalent + '((t :foreground "magenta")) + "Face for equivalent cherry commits." + :group 'magit-faces) + +(defface magit-filename + '((t :weight normal)) + "Face for filenames." + :group 'magit-faces) + +;;; Global Bindings + +;;;###autoload +(defcustom magit-define-global-key-bindings 'default + "Which set of key bindings to add to the global keymap, if any. + +This option controls which set of Magit key bindings, if any, may +be added to the global keymap, even before Magit is first used in +the current Emacs session. + +If the value is nil, no bindings are added. + +If \\+`default', maybe add: + + \\`C-x' \\`g' `magit-status' + \\`C-x' \\`M-g' `magit-dispatch' + \\`C-c' \\`M-g' `magit-file-dispatch' + +If `recommended', maybe add: + + \\`C-x' \\`g' `magit-status' + \\`C-c' \\`g' `magit-dispatch' + \\`C-c' \\`f' `magit-file-dispatch' + + These bindings are strongly recommended, but we cannot use + them by default, because the \\`C-c ' namespace is + strictly reserved for bindings added by the user. + +The bindings in the chosen set may be added when +`after-init-hook' is run. Each binding is added if, and only +if, at that time no other key is bound to the same command, +and no other command is bound to the same key. In other words +we try to avoid adding bindings that are unnecessary, as well +as bindings that conflict with other bindings. + +Adding these bindings is delayed until `after-init-hook' is +run to allow users to set the variable anywhere in their init +file (without having to make sure to do so before `magit' is +loaded or autoloaded) and to increase the likelihood that all +the potentially conflicting user bindings have already been +added. + +To set this variable use either `setq' or the Custom interface. +Do not use the function `customize-set-variable' because doing +that would cause Magit to be loaded immediately, when that form +is evaluated (this differs from `custom-set-variables', which +doesn't load the libraries that define the customized variables). + +Setting this variable has no effect if `after-init-hook' has +already been run." + :package-version '(magit . "4.0.0") + :group 'magit-essentials + :type '(choice (const :tag "Add no binding" nil) + (const :tag "Use default bindings" default) + (const :tag "Use recommended bindings" recommended))) + +;;;###autoload +(progn + (defun magit-maybe-define-global-key-bindings (&optional force) + "See variable `magit-define-global-key-bindings'." + (when magit-define-global-key-bindings + (let ((map (current-global-map))) + (pcase-dolist (`(,key . ,def) + (cond ((eq magit-define-global-key-bindings 'recommended) + '(("C-x g" . magit-status) + ("C-c g" . magit-dispatch) + ("C-c f" . magit-file-dispatch))) + ('(("C-x g" . magit-status) + ("C-x M-g" . magit-dispatch) + ("C-c M-g" . magit-file-dispatch))))) + ;; This is autoloaded and thus is used before `compat' is + ;; loaded, so we cannot use `keymap-lookup' and `keymap-set'. + (when (or force + (not (or (lookup-key map (kbd key)) + (where-is-internal def (make-sparse-keymap) t)))) + (define-key map (kbd key) def)))))) + (if after-init-time + (magit-maybe-define-global-key-bindings) + (add-hook 'after-init-hook #'magit-maybe-define-global-key-bindings t))) + +;;; Dispatch Popup + +;;;###autoload (autoload 'magit-dispatch "magit" nil t) +(transient-define-prefix magit-dispatch () + "Invoke a Magit command from a list of available commands." + :info-manual "(magit)Top" + ["Transient and dwim commands" + ;; → bound in magit-mode-map or magit-section-mode-map + ;; ↓ bound below + [("A" "Apply" magit-cherry-pick) + ;; a ↓ + ("b" "Branch" magit-branch) + ("B" "Bisect" magit-bisect) + ("c" "Commit" magit-commit) + ("C" "Clone" magit-clone) + ("d" "Diff" magit-diff) + ("D" "Diff (change)" magit-diff-refresh) + ("e" "Ediff (dwim)" magit-ediff-dwim) + ("E" "Ediff" magit-ediff) + ("f" "Fetch" magit-fetch) + ("F" "Pull" magit-pull) + ;; g ↓ + ;; G → magit-refresh-all + ("h" "Help" magit-info) + ("H" "Section info" magit-describe-section :if-derived magit-mode)] + [("i" "Ignore" magit-gitignore) + ("I" "Init" magit-init) + ("j" "Jump to section"magit-status-jump :if-mode magit-status-mode) + ("j" "Display status" magit-status-quick :if-not-mode magit-status-mode) + ("J" "Display buffer" magit-display-repository-buffer) + ;; k ↓ + ;; K → magit-file-untrack + ("l" "Log" magit-log) + ("L" "Log (change)" magit-log-refresh) + ("m" "Merge" magit-merge) + ("M" "Remote" magit-remote) + ;; n → magit-section-forward + ;; N reserved → forge-dispatch + ("o" "Submodule" magit-submodule) + ("O" "Subtree" magit-subtree) + ;; p → magit-section-backward + ("P" "Push" magit-push) + ;; q → magit-mode-bury-buffer + ("Q" "Command" magit-git-command)] + [("r" "Rebase" magit-rebase) + ;; R → magit-file-rename + ;; s ↓ + ;; S ↓ + ("t" "Tag" magit-tag) + ("T" "Note" magit-notes) + ;; u ↓ + ;; U ↓ + ;; v ↓ + ("V" "Revert" magit-revert) + ("w" "Apply patches" magit-am) + ("W" "Format patches" magit-patch) + ;; x → magit-reset-quickly + ("X" "Reset" magit-reset) + ("y" "Show Refs" magit-show-refs) + ("Y" "Cherries" magit-cherry) + ("z" "Stash" magit-stash) + ("Z" "Worktree" magit-worktree) + ("!" "Run" magit-run)]] + ["Applying changes" + :if-derived magit-mode + [("a" "Apply" magit-apply) + ("v" "Reverse" magit-reverse) + ("k" "Discard" magit-discard)] + [("s" "Stage" magit-stage) + ("u" "Unstage" magit-unstage)] + [("S" "Stage all" magit-stage-modified) + ("U" "Unstage all" magit-unstage-all)]] + ["Essential commands" + :if-derived magit-mode + [("g" " Refresh current buffer" magit-refresh) + ("q" " Bury current buffer" magit-mode-bury-buffer) + ("" " Toggle section at point" magit-section-toggle) + ("" "Visit thing at point" magit-visit-thing)] + [("C-x m" "Show all key bindings" describe-mode) + ("C-x i" "Show Info manual" magit-info)]]) + +;;; Git Popup + +(defcustom magit-shell-command-verbose-prompt t + "Whether to show the working directory when reading a command. +This affects `magit-git-command', `magit-git-command-topdir', +`magit-shell-command', and `magit-shell-command-topdir'." + :package-version '(magit . "2.11.0") + :group 'magit-commands + :type 'boolean) + +(defvar magit-git-command-history nil) + +;;;###autoload (autoload 'magit-run "magit" nil t) +(transient-define-prefix magit-run () + "Run git or another command, or launch a graphical utility." + [["Run git subcommand" + ("!" "in repository root" magit-git-command-topdir) + ("p" "in working directory" magit-git-command)] + ["Run shell command" + ("s" "in repository root" magit-shell-command-topdir) + ("S" "in working directory" magit-shell-command)] + ["Launch" + ("k" "gitk" magit-run-gitk) + ("a" "gitk --all" magit-run-gitk-all) + ("b" "gitk --branches" magit-run-gitk-branches) + ("g" "git gui" magit-run-git-gui) + ("m" "git mergetool --gui" magit-git-mergetool)]]) + +;;;###autoload +(defun magit-git-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +With a prefix argument COMMAND is run in the top-level directory +of the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command nil "git "))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-git-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. \"git \" is +used as initial input, but can be deleted to run another command. + +COMMAND is run in the top-level directory of the current +working tree." + (interactive (list (magit-read-shell-command t "git "))) + (magit--shell-command command (magit-toplevel))) + +;;;###autoload +(defun magit-shell-command (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. With a +prefix argument COMMAND is run in the top-level directory of +the current working tree, otherwise in `default-directory'." + (interactive (list (magit-read-shell-command))) + (magit--shell-command command)) + +;;;###autoload +(defun magit-shell-command-topdir (command) + "Execute COMMAND asynchronously; display output. + +Interactively, prompt for COMMAND in the minibuffer. COMMAND +is run in the top-level directory of the current working tree." + (interactive (list (magit-read-shell-command t))) + (magit--shell-command command (magit-toplevel))) + +(defun magit--shell-command (command &optional directory) + (let ((default-directory (or directory default-directory))) + (with-environment-variables (("GIT_PAGER" "cat")) + (with-connection-local-variables + (magit-with-editor + (magit-start-process shell-file-name nil + shell-command-switch command))))) + (magit-process-buffer)) + +(defun magit-read-shell-command (&optional toplevel initial-input) + (let ((default-directory + (if (or toplevel current-prefix-arg) + (or (magit-toplevel) + (magit--not-inside-repository-error)) + default-directory))) + (read-shell-command (if magit-shell-command-verbose-prompt + (format "Async shell command in %s: " + (abbreviate-file-name default-directory)) + "Async shell command: ") + initial-input 'magit-git-command-history))) + +;;; Shared Infix Arguments + +(transient-define-argument magit:--signoff () + :description "Add Signed-off-by trailer" + :class 'transient-switch + :key "+s" + :shortarg "-s" + :argument "--signoff" + :level 6) + +(transient-define-argument magit:--gpg-sign () + :description "Sign using gpg" + :class 'transient-option + :shortarg "-S" + :argument "--gpg-sign=" + :allow-empty t + :reader #'magit-read-gpg-signing-key + :level 5) + +(defvar magit-gpg-secret-key-hist nil) + +(defun magit-read-gpg-secret-key + (prompt &optional initial-input history predicate default) + (require 'epa) + (let* ((keys (mapcan + (lambda (cert) + (and (or (not predicate) + (funcall predicate cert)) + (let* ((key (car (epg-key-sub-key-list cert))) + (fpr (epg-sub-key-fingerprint key)) + (id (epg-sub-key-id key)) + (author + (and-let* ((id-obj + (car (epg-key-user-id-list cert)))) + (let ((id-str (epg-user-id-string id-obj))) + (if (stringp id-str) + id-str + (epg-decode-dn id-obj)))))) + (list + (propertize fpr 'display + (concat (substring fpr 0 (- (length id))) + (propertize id 'face 'highlight) + " " author)))))) + (epg-list-keys (epg-make-context epa-protocol) nil t))) + (choice (or (and (not current-prefix-arg) + (or (and (length= keys 1) (car keys)) + (and default (car (member default keys))))) + (completing-read prompt keys nil nil nil + history nil initial-input)))) + (set-text-properties 0 (length choice) nil choice) + choice)) + +(defun magit-read-gpg-signing-key (prompt &optional initial-input history) + (magit-read-gpg-secret-key + prompt initial-input history + (lambda (cert) + (cl-some (lambda (key) + (memq 'sign (epg-sub-key-capability key))) + (epg-key-sub-key-list cert))) + magit-openpgp-default-signing-key)) + +;;; Font-Lock Keywords + +(defconst magit-font-lock-keywords + (eval-when-compile + `((,(concat "(\\(magit-define-section-jumper\\)\\_>" + "[ \t'(]*" + "\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face nil t)) + (,(concat "(" (regexp-opt '("magit-insert-section" + "magit-insert-heading" + "magit-section-case" + "magit-bind-match-strings" + "magit-with-temp-index" + "magit-with-blob" + "magit-with-toplevel") + t) + "\\_>") + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode magit-font-lock-keywords) + +;;; Version + +(defvar magit-version #'undefined + "The version of Magit that you're using. +Use the function by the same name instead of this variable.") + +;;;###autoload +(defun magit-version (&optional print-dest interactive nowarn) + "Return the version of Magit currently in use. + +If optional argument PRINT-DEST is non-nil, also print the used +versions of Magit, Transient, Git and Emacs to the output stream +selected by that argument. Interactively use the echo area, or +with a prefix argument use the current buffer. Additionally put +the output in the kill ring. +\n(fn &optional PRINT-DEST)" + (interactive (list (if current-prefix-arg (current-buffer) t) t)) + (let ((magit-git-global-arguments nil) + (toplib (or load-file-name buffer-file-name)) + debug) + (unless (and toplib + (member (file-name-nondirectory toplib) + '("magit.el" "magit.el.gz"))) + (let ((load-suffixes (reverse load-suffixes))) ; prefer .el than .elc + (setq toplib (locate-library "magit")))) + (setq toplib (and toplib (magit--chase-links toplib))) + (push toplib debug) + (when toplib + (let* ((topdir (file-name-directory toplib)) + (gitdir (expand-file-name + ".git" (file-name-directory + (directory-file-name topdir)))) + (static (locate-library "magit-version.el" nil (list topdir))) + (static (and static (magit--chase-links static)))) + (or (progn + (push 'repo debug) + (when (and (file-exists-p gitdir) + ;; It is a repo, but is it the Magit repo? + (file-exists-p + (expand-file-name "../lisp/magit.el" gitdir))) + (push t debug) + ;; Inside the repo the version file should only exist + ;; while running make. + (when (and static (not noninteractive)) + (ignore-errors (delete-file static))) + (setq magit-version + (let ((default-directory topdir)) + (magit-git-string "describe" + "--tags" "--dirty" "--always"))))) + (progn + (push 'static debug) + (when (and static (file-exists-p static)) + (push t debug) + (load-file static) + magit-version)) + (when (featurep 'package) + (push 'elpa debug) + (ignore-errors + (when-let ((version (cadr (assq 'magit package-alist)))) + (push t debug) + (setq magit-version + (and (fboundp 'package-desc-version) + (package-version-join + (package-desc-version version))))))) + (progn + (push 'dirname debug) + (let ((dirname (file-name-nondirectory + (directory-file-name topdir)))) + (when (string-match "\\`magit-\\([0-9].*\\)" dirname) + (setq magit-version (match-string 1 dirname))))) + ;; If all else fails, just report the commit hash. It's + ;; better than nothing and we cannot do better in the case + ;; of e.g., a shallow clone. + (progn + (push 'hash debug) + ;; Same check as above to see if it's really the Magit repo. + (when (and (file-exists-p gitdir) + (file-exists-p + (expand-file-name "../lisp/magit.el" gitdir))) + (setq magit-version + (let ((default-directory topdir)) + (magit-git-string "rev-parse" "HEAD")))))))) + (if (stringp magit-version) + (when print-dest + (let ((str (format + "Magit %s%s, Transient %s,%s Git %s, Emacs %s, %s" + (or magit-version "(unknown)") + (or (and (ignore-errors + (magit--version>= magit-version "2008")) + (ignore-errors + (require 'lisp-mnt) + (and (fboundp 'lm-header) + (format + " [>= %s]" + (with-temp-buffer + (insert-file-contents + (locate-library "magit.el" t)) + (lm-header "Package-Version")))))) + "") + (or (ignore-errors + (require 'lisp-mnt) + (and (fboundp 'lm-header) + (with-temp-buffer + (insert-file-contents + (locate-library "transient.el" t)) + (lm-header "Package-Version")))) + "(unknown)") + (let ((lib (locate-library "forge.el" t))) + (or (and lib + (format + " Forge %s," + (or (ignore-errors + (require 'lisp-mnt) + (with-temp-buffer + (insert-file-contents lib) + (and (fboundp 'lm-header) + (lm-header "Package-Version")))) + "(unknown)"))) + "")) + (magit--safe-git-version) + emacs-version + system-type))) + (when interactive + (kill-new str)) + (princ str print-dest))) + (setq debug (reverse debug)) + (setq magit-version 'error) + (when magit-version + (push magit-version debug)) + (unless (or nowarn (equal (getenv "CI") "true")) + (message "Cannot determine Magit's version %S" debug))) + magit-version)) + +;;; Startup Asserts + +(defun magit-startup-asserts () + (when-let ((val (getenv "GIT_DIR"))) + (setenv "GIT_DIR") + (message + "Magit unset $GIT_DIR (was %S). See %s" val + ;; Note: Pass URL as argument rather than embedding in the format + ;; string to prevent the single quote from being rendered + ;; according to `text-quoting-style'. + "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) + (when-let ((val (getenv "GIT_WORK_TREE"))) + (setenv "GIT_WORK_TREE") + (message + "Magit unset $GIT_WORK_TREE (was %S). See %s" val + ;; See comment above. + "https://github.com/magit/magit/wiki/Don't-set-$GIT_DIR-and-alike")) + ;; Git isn't required while building Magit. + (unless (bound-and-true-p byte-compile-current-file) + (magit-git-version-assert)) + (when (version< emacs-version magit--minimal-emacs) + (display-warning 'magit (format "\ +Magit requires Emacs >= %s, you are using %s. + +If this comes as a surprise to you, because you do actually have +a newer version installed, then that probably means that the +older version happens to appear earlier on the `$PATH'. If you +always start Emacs from a shell, then that can be fixed in the +shell's init file. If you start Emacs by clicking on an icon, +or using some sort of application launcher, then you probably +have to adjust the environment as seen by graphical interface. +For X11 something like ~/.xinitrc should work.\n" + magit--minimal-emacs emacs-version) + :error))) + +;;; Loading Libraries + +(provide 'magit) + +(cl-eval-when (load eval) + (require 'magit-status) + (require 'magit-refs) + (require 'magit-files) + (require 'magit-reset) + (require 'magit-branch) + (require 'magit-merge) + (require 'magit-tag) + (require 'magit-worktree) + (require 'magit-notes) + (require 'magit-sequence) + (require 'magit-commit) + (require 'magit-remote) + (require 'magit-clone) + (require 'magit-fetch) + (require 'magit-pull) + (require 'magit-push) + (require 'magit-bisect) + (require 'magit-stash) + (require 'magit-blame) + (require 'magit-submodule) + (unless (load "magit-autoloads" t t) + (require 'magit-patch) + (require 'magit-subtree) + (require 'magit-ediff) + (require 'magit-gitignore) + (require 'magit-sparse-checkout) + (require 'magit-extras) + (require 'magit-dired) + (require 'git-rebase) + (require 'magit-bookmark))) + +(with-eval-after-load 'bookmark + (require 'magit-bookmark)) + +(unless (bound-and-true-p byte-compile-current-file) + (if after-init-time + (progn (magit-startup-asserts) + (magit-version nil nil t)) + (add-hook 'after-init-hook #'magit-startup-asserts t) + (add-hook 'after-init-hook #'magit-version t))) + +;;; magit.el ends here blob - /dev/null blob + 957666f01580cb4400bed1fe229af14fb2a32d80 (mode 644) --- /dev/null +++ elpa/magit-4.3.8/magit.info @@ -0,0 +1,10350 @@ +This is doc5khxAZ.info, produced by makeinfo version 6.8 from +magit.texi. + + Copyright (C) 2015-2025 Jonas Bernoulli + + + You can redistribute this document and/or modify it under the terms + of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) + any later version. + + This document 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. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Magit: (magit). Using Git from Emacs with Magit. +END-INFO-DIR-ENTRY + + +File: doc5khxAZ.info, Node: Top, Next: Introduction, Up: (dir) + +Magit User Manual +***************** + +Magit is an interface to the version control system Git, implemented as +an Emacs package. Magit aspires to be a complete Git porcelain. While +we cannot (yet) claim that Magit wraps and improves upon each and every +Git command, it is complete enough to allow even experienced Git users +to perform almost all of their daily version control tasks directly from +within Emacs. While many fine Git clients exist, only Magit and Git +itself deserve to be called porcelains. + +This manual is for Magit version 4.3.8. + + Copyright (C) 2015-2025 Jonas Bernoulli + + + You can redistribute this document and/or modify it under the terms + of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) + any later version. + + This document 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. + +* Menu: + +* Introduction:: +* Installation:: +* Getting Started:: +* Interface Concepts:: +* Inspecting:: +* Manipulating:: +* Transferring:: +* Miscellaneous:: +* Customizing:: +* Plumbing:: +* FAQ:: +* Debugging Tools:: +* Keystroke Index:: +* Function and Command Index:: +* Variable Index:: + +— The Detailed Node Listing — + +Installation + +* Installing from Melpa:: +* Installing from the Git Repository:: +* Post-Installation Tasks:: + +Interface Concepts + +* Modes and Buffers:: +* Sections:: +* Transient Commands:: +* Transient Arguments and Buffer Variables:: +* Completion, Confirmation and the Selection: Completion Confirmation and the Selection. +* Mouse Support:: +* Running Git:: + +Modes and Buffers + +* Switching Buffers:: +* Naming Buffers:: +* Quitting Windows:: +* Automatic Refreshing of Magit Buffers:: +* Automatic Saving of File-Visiting Buffers:: +* Automatic Reverting of File-Visiting Buffers:: + + +Sections + +* Section Movement:: +* Section Visibility:: +* Section Hooks:: +* Section Types and Values:: +* Section Options:: + + +Completion, Confirmation and the Selection + +* Action Confirmation:: +* Completion and Confirmation:: +* The Selection:: +* The hunk-internal region:: +* Support for Completion Frameworks:: +* Additional Completion Options:: + + +Running Git + +* Viewing Git Output:: +* Git Process Status:: +* Running Git Manually:: +* Git Executable:: +* Global Git Arguments:: + + +Inspecting + +* Status Buffer:: +* Repository List:: +* Logging:: +* Diffing:: +* Ediffing:: +* References Buffer:: +* Bisecting:: +* Visiting Files and Blobs:: +* Blaming:: + +Status Buffer + +* Status Sections:: +* Status File List Sections:: +* Status Log Sections:: +* Status Header Sections:: +* Status Module Sections:: +* Status Options:: + + +Logging + +* Refreshing Logs:: +* Log Buffer:: +* Log Margin:: +* Select from Log:: +* Reflog:: +* Cherries:: + + +Diffing + +* Refreshing Diffs:: +* Commands Available in Diffs:: +* Diff Options:: +* Revision Buffer:: + + +References Buffer + +* References Sections:: + + +Visiting Files and Blobs + +* General-Purpose Visit Commands:: +* Visiting Files and Blobs from a Diff:: + + +Manipulating + +* Creating Repository:: +* Cloning Repository:: +* Staging and Unstaging:: +* Applying:: +* Committing:: +* Branching:: +* Merging:: +* Resolving Conflicts:: +* Rebasing:: +* Cherry Picking:: +* Resetting:: +* Stashing:: + +Staging and Unstaging + +* Staging from File-Visiting Buffers:: + + +Committing + +* Initiating a Commit:: +* Editing Commit Messages:: + + +Branching + +* The Two Remotes:: +* Branch Commands:: +* Branch Git Variables:: +* Auxiliary Branch Commands:: + + +Rebasing + +* Editing Rebase Sequences:: +* Information About In-Progress Rebase:: + + +Cherry Picking + +* Reverting:: + + +Transferring + +* Remotes:: +* Fetching:: +* Pulling:: +* Pushing:: +* Plain Patches:: +* Maildir Patches:: + +Remotes + +* Remote Commands:: +* Remote Git Variables:: + + +Miscellaneous + +* Tagging:: +* Notes:: +* Submodules:: +* Subtree:: +* Worktree:: +* Sparse checkouts:: +* Bundle:: +* Common Commands:: +* Wip Modes:: +* Commands for Buffers Visiting Files:: +* Minor Mode for Buffers Visiting Blobs:: + +Submodules + +* Listing Submodules:: +* Submodule Transient:: + + +Wip Modes + +* Wip Graph:: +* Legacy Wip Modes:: + + +Customizing + +* Per-Repository Configuration:: +* Essential Settings:: + +Essential Settings + +* Safety:: +* Performance:: +* Global Bindings:: + + +Plumbing + +* Calling Git:: +* Section Plumbing:: +* Refreshing Buffers:: +* Conventions:: + +Calling Git + +* Getting a Value from Git:: +* Calling Git for Effect:: + + +Section Plumbing + +* Creating Sections:: +* Section Selection:: +* Matching Sections:: + + +Conventions + +* Theming Faces:: + + +FAQ + +* FAQ - How to ...?:: +* FAQ - Issues and Errors:: + +FAQ - How to ...? + +* How to pronounce Magit?:: +* How to show git's output?:: +* How to install the gitman info manual?:: +* How to show diffs for gpg-encrypted files?:: +* How does branching and pushing work?:: +* Should I disable VC?:: + + +FAQ - Issues and Errors + +* Magit is slow:: +* I changed several thousand files at once and now Magit is unusable:: +* I am having problems committing:: +* I am using MS Windows and cannot push with Magit:: +* I am using macOS and SOMETHING works in shell, but not in Magit: I am using macOS and SOMETHING works in shell but not in Magit. +* Expanding a file to show the diff causes it to disappear:: +* Point is wrong in the COMMIT_EDITMSG buffer:: +* The mode-line information isn't always up-to-date:: +* A branch and tag sharing the same name breaks SOMETHING:: +* My Git hooks work on the command-line but not inside Magit:: +* git-commit-mode isn't used when committing from the command-line:: +* Point ends up inside invisible text when jumping to a file-visiting buffer:: +* I am no longer able to save popup defaults:: + + + + +File: doc5khxAZ.info, Node: Introduction, Next: Installation, Prev: Top, Up: Top + +1 Introduction +************** + +Magit is an interface to the version control system Git, implemented as +an Emacs package. Magit aspires to be a complete Git porcelain. While +we cannot (yet) claim that Magit wraps and improves upon each and every +Git command, it is complete enough to allow even experienced Git users +to perform almost all of their daily version control tasks directly from +within Emacs. While many fine Git clients exist, only Magit and Git +itself deserve to be called porcelains. + + Staging and otherwise applying changes is one of the most important +features in a Git porcelain and here Magit outshines anything else, +including Git itself. Git’s own staging interface (‘git add --patch’) +is so cumbersome that many users only use it in exceptional cases. In +Magit staging a hunk or even just part of a hunk is as trivial as +staging all changes made to a file. + + The most visible part of Magit’s interface is the status buffer, +which displays information about the current repository. Its content is +created by running several Git commands and making their output +actionable. Among other things, it displays information about the +current branch, lists unpulled and unpushed changes and contains +sections displaying the staged and unstaged changes. That might sound +noisy, but, since sections are collapsible, it’s not. + + To stage or unstage a change one places the cursor on the change and +then types ‘s’ or ‘u’. The change can be a file or a hunk, or when the +region is active (i.e., when there is a selection) several files or +hunks, or even just part of a hunk. The change or changes that these +commands - and many others - would act on are highlighted. + + Magit also implements several other "apply variants" in addition to +staging and unstaging. One can discard or reverse a change, or apply it +to the working tree. Git’s own porcelain only supports this for staging +and unstaging and you would have to do something like ‘git diff ... | +??? | git apply ...’ to discard, revert, or apply a single hunk on the +command line. In fact that’s exactly what Magit does internally (which +is what lead to the term "apply variants"). + + Magit isn’t just for Git experts, but it does assume some prior +experience with Git as well as Emacs. That being said, many users have +reported that using Magit was what finally taught them what Git is +capable of and how to use it to its fullest. Other users wished they +had switched to Emacs sooner so that they would have gotten their hands +on Magit earlier. + + While one has to know the basic features of Emacs to be able to make +full use of Magit, acquiring just enough Emacs skills doesn’t take long +and is worth it, even for users who prefer other editors. Vim users are +advised to give Evil (https://github.com/emacs-evil/evil), the +"Extensible VI Layer for Emacs", and Spacemacs +(https://github.com/syl20bnr/spacemacs), an "Emacs starter-kit focused +on Evil" a try. + + Magit provides a consistent and efficient Git porcelain. After a +short learning period, you will be able to perform most of your daily +version control tasks faster than you would on the command line. You +will likely also start using features that seemed too daunting in the +past. + + Magit fully embraces Git. It exposes many advanced features using a +simple but flexible interface instead of only wrapping the trivial ones +like many GUI clients do. Of course Magit supports logging, cloning, +pushing, and other commands that usually don’t fail in spectacular ways; +but it also supports tasks that often cannot be completed in a single +step. Magit fully supports tasks such as merging, rebasing, +cherry-picking, reverting, and blaming by not only providing a command +to initiate these tasks but also by displaying context sensitive +information along the way and providing commands that are useful for +resolving conflicts and resuming the sequence after doing so. + + Magit wraps and in many cases improves upon at least the following +Git porcelain commands: ‘add’, ‘am’, ‘bisect’, ‘blame’, ‘branch’, +‘checkout’, ‘cherry’, ‘cherry-pick’, ‘clean’, ‘clone’, ‘commit’, +‘config’, ‘describe’, ‘diff’, ‘fetch’, ‘format-patch’, ‘init’, ‘log’, +‘merge’, ‘merge-tree’, ‘mv’, ‘notes’, ‘pull’, ‘rebase’, ‘reflog’, +‘remote’, ‘request-pull’, ‘reset’, ‘revert’, ‘rm’, ‘show’, ‘stash’, +‘submodule’, ‘subtree’, ‘tag’, and ‘worktree.’ Many more Magit porcelain +commands are implemented on top of Git plumbing commands. + + +File: doc5khxAZ.info, Node: Installation, Next: Getting Started, Prev: Introduction, Up: Top + +2 Installation +************** + +Magit can be installed using Emacs’ package manager or manually from its +development repository. + +* Menu: + +* Installing from Melpa:: +* Installing from the Git Repository:: +* Post-Installation Tasks:: + + +File: doc5khxAZ.info, Node: Installing from Melpa, Next: Installing from the Git Repository, Up: Installation + +2.1 Installing from Melpa +========================= + +Magit is available from Melpa and Melpa-Stable. If you haven’t used +Emacs’ package manager before, then it is high time you familiarize +yourself with it by reading the documentation in the Emacs manual, see +*note (emacs)Packages::. Then add one of the archives to +‘package-archives’: + + • To use Melpa: + + (require 'package) + (add-to-list 'package-archives + '("melpa" . "https://melpa.org/packages/") t) + + • To use Melpa-Stable: + + (require 'package) + (add-to-list 'package-archives + '("melpa-stable" . "https://stable.melpa.org/packages/") t) + + Once you have added your preferred archive, you need to update the +local package list using: + + M-x package-refresh-contents RET + + Once you have done that, you can install Magit and its dependencies +using: + + M-x package-install RET magit RET + + Now see *note Post-Installation Tasks::. + + +File: doc5khxAZ.info, Node: Installing from the Git Repository, Next: Post-Installation Tasks, Prev: Installing from Melpa, Up: Installation + +2.2 Installing from the Git Repository +====================================== + +Magit depends on the ‘compat’, ‘llama’, ‘seq’ (the built-in version is +enough when using Emacs >= 29.1), ‘transient’ and ‘with-editor’ +libraries which are available from Melpa and Melpa-Stable. Install them +using ‘M-x package-install RET RET’. Of course you may also +install them manually from their repository. + + Then clone the Magit repository: + + $ git clone https://github.com/magit/magit.git ~/.emacs.d/site-lisp/magit + $ cd ~/.emacs.d/site-lisp/magit + + Then compile the libraries and generate the info manuals: + + $ make + + If you haven’t installed ‘compat’, ‘llama’, ‘seq’ (for Emacs < 29.1), +‘transient’ and ‘with-editor’ from Melpa, or at +‘/path/to/magit/../’, then you have to tell ‘make’ where to +find them. To do so create the file ‘/path/to/magit/config.mk’ with the +following content before running ‘make’: + + LOAD_PATH = -L ~/.emacs.d/site-lisp/magit/lisp + LOAD_PATH += -L ~/.emacs.d/site-lisp/compat + LOAD_PATH += -L ~/.emacs.d/site-lisp/llama + LOAD_PATH += -L ~/.emacs.d/site-lisp/seq + LOAD_PATH += -L ~/.emacs.d/site-lisp/transient/lisp + LOAD_PATH += -L ~/.emacs.d/site-lisp/with-editor/lisp + + Finally add this to your init file: + + (add-to-list 'load-path "~/.emacs.d/site-lisp/magit/lisp") + (require 'magit) + + (with-eval-after-load 'info + (info-initialize) + (add-to-list 'Info-directory-list "~/.emacs.d/site-lisp/magit/docs/")) + + Of course if you installed the dependencies manually as well, then +you have to tell Emacs about them too, by prefixing the above with: + + (add-to-list 'load-path "~/.emacs.d/site-lisp/compat") + (add-to-list 'load-path "~/.emacs.d/site-lisp/llama") + (add-to-list 'load-path "~/.emacs.d/site-lisp/seq") + (add-to-list 'load-path "~/.emacs.d/site-lisp/transient/lisp") + (add-to-list 'load-path "~/.emacs.d/site-lisp/with-editor") + + Note that you have to add the ‘lisp’ subdirectory to the ‘load-path’, +not the top-level of the repository, and that elements of ‘load-path’ +should not end with a slash, while those of ‘Info-directory-list’ +should. + + Instead of requiring the feature ‘magit’, you could load just the +autoload definitions, by loading the file ‘magit-autoloads.el’. + + (load "/path/to/magit/lisp/magit-autoloads") + + Instead of running Magit directly from the repository by adding that +to the ‘load-path’, you might want to instead install it in some other +directory using ‘sudo make install’ and setting ‘load-path’ accordingly. + + To update Magit use: + + $ git pull + $ make + + At times it might be necessary to run ‘make clean all’ instead. + + To view all available targets use ‘make help’. + + Now see *note Post-Installation Tasks::. + + +File: doc5khxAZ.info, Node: Post-Installation Tasks, Prev: Installing from the Git Repository, Up: Installation + +2.3 Post-Installation Tasks +=========================== + +After installing Magit you should verify that you are indeed using the +Magit, Git, and Emacs releases you think you are using. It’s best to +restart Emacs before doing so, to make sure you are not using an +outdated value for ‘load-path’. + + M-x magit-version RET + + should display something like + + Magit 2.8.0, Git 2.10.2, Emacs 25.1.1, gnu/linux + + Then you might also want to read about options that many users likely +want to customize. See *note Essential Settings::. + + To be able to follow cross references to Git manpages found in this +manual, you might also have to manually install the ‘gitman’ info +manual, or advice ‘Info-follow-nearest-node’ to instead open the actual +manpage. See *note How to install the gitman info manual?::. + + If you are completely new to Magit then see *note Getting Started::. + + If you run into problems, then please see the *note FAQ::. Also see +the *note Debugging Tools::. + + And last but not least please consider making a donation, to ensure +that I can keep working on Magit. See . for +various donation options. + + +File: doc5khxAZ.info, Node: Getting Started, Next: Interface Concepts, Prev: Installation, Up: Top + +3 Getting Started +***************** + +This short tutorial describes the most essential features that many +Magitians use on a daily basis. It only scratches the surface but +should be enough to get you started. + + IMPORTANT: It is safest if you clone some repository just for this +tutorial. Alternatively you can use an existing local repository, but +if you do that, then you should commit all uncommitted changes before +proceeding. + + Type ‘C-x g’ to display information about the current Git repository +in a dedicated buffer, called the status buffer. + + Most Magit commands are commonly invoked from the status buffer. It +can be considered the primary interface for interacting with Git using +Magit. Many other Magit buffers may exist at a given time, but they are +often created from this buffer. + + Depending on what state your repository is in, this buffer may +contain sections titled "Staged changes", "Unstaged changes", "Unmerged +into origin/master", "Unpushed to origin/master", and many others. + + Since we are starting from a safe state, which you can easily return +to (by doing a ‘git reset --hard PRE-MAGIT-STATE’), there currently are +no staged or unstaged changes. Edit some files and save the changes. +Then go back to the status buffer, while at the same time refreshing it, +by typing ‘C-x g’. (When the status buffer, or any Magit buffer for +that matter, is the current buffer, then you can also use just ‘g’ to +refresh it). + + Move between sections using ‘p’ and ‘n’. Note that the bodies of +some sections are hidden. Type ‘TAB’ to expand or collapse the section +at point. You can also use ‘C-tab’ to cycle the visibility of the +current section and its children. Move to a file section inside the +section named "Unstaged changes" and type ‘s’ to stage the changes you +have made to that file. That file now appears under "Staged changes". + + Magit can stage and unstage individual hunks, not just complete +files. Move to the file you have just staged, expand it using ‘TAB’, +move to one of the hunks using ‘n’, and unstage just that by typing ‘u’. +Note how the staging (‘s’) and unstaging (‘u’) commands operate on the +change at point. Many other commands behave the same way. + + You can also un-/stage just part of a hunk. Inside the body of a +hunk section (move there using ‘C-n’), set the mark using ‘C-SPC’ and +move down until some added and/or removed lines fall inside the region +but not all of them. Again type ‘s’ to stage. + + It is also possible to un-/stage multiple files at once. Move to a +file section, type ‘C-SPC’, move to the next file using ‘n’, and then +‘s’ to stage both files. Note that both the mark and point have to be +on the headings of sibling sections for this to work. If the region +looks like it does in other buffers, then it doesn’t select Magit +sections that can be acted on as a unit. + + And then of course you want to commit your changes. Type ‘c’. This +shows the available commit commands and arguments in a buffer at the +bottom of the frame. Each command and argument is prefixed with the key +that invokes/sets it. Do not worry about this for now. We want to +create a "normal" commit, which is done by typing ‘c’ again. + + Now two new buffers appear. One is for writing the commit message, +the other shows a diff with the changes that you are about to commit. +Write a message and then type ‘C-c C-c’ to actually create the commit. + + You probably don’t want to push the commit you just created because +you just committed some random changes, but if that is not the case you +could push it by typing ‘P’ to show all the available push commands and +arguments and then ‘p’ to push to a branch with the same name as the +local branch onto the remote configured as the push-remote. (If the +push-remote is not configured yet, then you would first be prompted for +the remote to push to.) + + So far we have mentioned the commit and push menu commands. These +are probably among the menus you will be using the most, but many others +exist. To show a menu that lists all other menus (as well as the +various apply commands and some other essential commands), type ‘h’. +Try a few. (Such menus are also called "transient prefix commands" or +just "transients".) + + The key bindings in that menu correspond to the bindings in Magit +buffers, including but not limited to the status buffer. So you could +type ‘h d’ to bring up the diff menu, but once you remember that "d" +stands for "diff", you would usually do so by just typing ‘d’. + + This "prefix of prefixes" is useful even once you have memorized all +the bindings, as it can provide easy access to Magit commands from +non-Magit buffers. So, by default, it is globally bound to ‘C-x M-g’. + + A similar menu featuring (for the most part) commands that act on +just the file being visited in the current buffer, is globally bound to +‘C-c M-g’. That binding can also be used in buffers, which do not visit +a file, but then only a subset of the commands is available. + + The global key bindings mentioned in the previous two paragraphs are +quite inconvenient. We recommend using ‘C-c g’ and ‘C-c f’ instead, but +cannot use those key sequences by default because they are strictly +reserved for bindings added by the user. See *note Global Bindings::, +if you want to explicitly opt-in to the recommended key bindings. + + Magit also provides context menus and other mouse commands, see *note +Mouse Support::. + + It is not necessary that you do so now, but if you stick with Magit, +then it is highly recommended that you read the next section too. + + +File: doc5khxAZ.info, Node: Interface Concepts, Next: Inspecting, Prev: Getting Started, Up: Top + +4 Interface Concepts +******************** + +* Menu: + +* Modes and Buffers:: +* Sections:: +* Transient Commands:: +* Transient Arguments and Buffer Variables:: +* Completion, Confirmation and the Selection: Completion Confirmation and the Selection. +* Mouse Support:: +* Running Git:: + + +File: doc5khxAZ.info, Node: Modes and Buffers, Next: Sections, Up: Interface Concepts + +4.1 Modes and Buffers +===================== + +Magit provides several major-modes. For each of these modes there +usually exists only one buffer per repository. Separate modes and thus +buffers exist for commits, diffs, logs, and some other things. + + Besides these special purpose buffers, there also exists an overview +buffer, called the *status buffer*. It’s usually from this buffer that +the user invokes Git commands, or creates or visits other buffers. + + In this manual we often speak about "Magit buffers". By that we mean +buffers whose major-modes derive from ‘magit-mode’. + +Key: M-x magit-toggle-buffer-lock + This command locks the current buffer to its value or if the buffer + is already locked, then it unlocks it. + + Locking a buffer to its value prevents it from being reused to + display another value. The name of a locked buffer contains its + value, which allows telling it apart from other locked buffers and + the unlocked buffer. + + Not all Magit buffers can be locked to their values; for example, + it wouldn’t make sense to lock a status buffer. + + There can only be a single unlocked buffer using a certain + major-mode per repository. So when a buffer is being unlocked and + another unlocked buffer already exists for that mode and + repository, then the former buffer is instead deleted and the + latter is displayed in its place. + +* Menu: + +* Switching Buffers:: +* Naming Buffers:: +* Quitting Windows:: +* Automatic Refreshing of Magit Buffers:: +* Automatic Saving of File-Visiting Buffers:: +* Automatic Reverting of File-Visiting Buffers:: + + +File: doc5khxAZ.info, Node: Switching Buffers, Next: Naming Buffers, Up: Modes and Buffers + +4.1.1 Switching Buffers +----------------------- + +Function: magit-display-buffer buffer &optional display-function + This function is a wrapper around ‘display-buffer’ and is used to + display any Magit buffer. It displays BUFFER in some window and, + unlike ‘display-buffer’, also selects that window, provided + ‘magit-display-buffer-noselect’ is ‘nil’. It also runs the hooks + mentioned below. + + If optional DISPLAY-FUNCTION is non-nil, then that is used to + display the buffer. Usually that is ‘nil’ and the function + specified by ‘magit-display-buffer-function’ is used. + +Variable: magit-display-buffer-noselect + When this is non-nil, then ‘magit-display-buffer’ only displays the + buffer but forgoes also selecting the window. This variable should + not be set globally, it is only intended to be let-bound, by code + that automatically updates "the other window". This is used for + example when the revision buffer is updated when you move inside + the log buffer. + +User Option: magit-display-buffer-function + The function specified here is called by ‘magit-display-buffer’ + with one argument, a buffer, to actually display that buffer. This + function should call ‘display-buffer’ with that buffer as first and + a list of display actions as second argument. + + Magit provides several functions, listed below, that are suitable + values for this option. If you want to use different rules, then a + good way of doing that is to start with a copy of one of these + functions and then adjust it to your needs. + + Instead of using a wrapper around ‘display-buffer’, that function + itself can be used here, in which case the display actions have to + be specified by adding them to ‘display-buffer-alist’ instead. + + To learn about display actions, see *note (elisp)Choosing Window::. + +Function: magit-display-buffer-traditional buffer + This function is the current default value of the option + ‘magit-display-buffer-function’. Before that option and this + function were added, the behavior was hard-coded in many places all + over the code base but now all the rules are contained in this one + function (except for the "noselect" special case mentioned above). + +Function: magit-display-buffer-same-window-except-diff-v1 + This function displays most buffers in the currently selected + window. If a buffer’s mode derives from ‘magit-diff-mode’ or + ‘magit-process-mode’, it is displayed in another window. + +Function: magit-display-buffer-fullframe-status-v1 + This function fills the entire frame when displaying a status + buffer. Otherwise, it behaves like + ‘magit-display-buffer-traditional’. + +Function: magit-display-buffer-fullframe-status-topleft-v1 + This function fills the entire frame when displaying a status + buffer. It behaves like ‘magit-display-buffer-fullframe-status-v1’ + except that it displays buffers that derive from ‘magit-diff-mode’ + or ‘magit-process-mode’ to the top or left of the current buffer + rather than to the bottom or right. As a result, Magit buffers + tend to pop up on the same side as they would if + ‘magit-display-buffer-traditional’ were in use. + +Function: magit-display-buffer-fullcolumn-most-v1 + This function displays most buffers so that they fill the entire + height of the frame. However, the buffer is displayed in another + window if (1) the buffer’s mode derives from ‘magit-process-mode’, + or (2) the buffer’s mode derives from ‘magit-diff-mode’, provided + that the mode of the current buffer derives from ‘magit-log-mode’ + or ‘magit-cherry-mode’. + +User Option: magit-pre-display-buffer-hook + This hook is run by ‘magit-display-buffer’ before displaying the + buffer. + +Function: magit-save-window-configuration + This function saves the current window configuration. Later when + the buffer is buried, it may be restored by + ‘magit-restore-window-configuration’. + +User Option: magit-post-display-buffer-hook + This hook is run by ‘magit-display-buffer’ after displaying the + buffer. + +Function: magit-maybe-set-dedicated + This function remembers if a new window had to be created to + display the buffer, or whether an existing window was reused. This + information is later used by ‘magit-mode-quit-window’, to determine + whether the window should be deleted when its last Magit buffer is + buried. + + +File: doc5khxAZ.info, Node: Naming Buffers, Next: Quitting Windows, Prev: Switching Buffers, Up: Modes and Buffers + +4.1.2 Naming Buffers +-------------------- + +User Option: magit-generate-buffer-name-function + The function used to generate the names of Magit buffers. + + Such a function should take the options + ‘magit-uniquify-buffer-names’ as well as ‘magit-buffer-name-format’ + into account. If it doesn’t, then should be clearly stated in the + doc-string. And if it supports %-sequences beyond those mentioned + in the doc-string of the option ‘magit-buffer-name-format’, then + its own doc-string should describe the additions. + +Function: magit-generate-buffer-name-default-function mode + This function returns a buffer name suitable for a buffer whose + major-mode is MODE and which shows information about the repository + in which ‘default-directory’ is located. + + This function uses ‘magit-buffer-name-format’ and supporting all of + the %-sequences mentioned the documentation of that option. It + also respects the option ‘magit-uniquify-buffer-names’. + +User Option: magit-buffer-name-format + The format string used to name Magit buffers. + + At least the following %-sequences are supported: + + • ‘%m’ + + The name of the major-mode, but with the ‘-mode’ suffix + removed. + + • ‘%M’ + + Like ‘%m’ but abbreviate ‘magit-status-mode’ as ‘magit’. + + • ‘%v’ + + The value the buffer is locked to, in parentheses, or an empty + string if the buffer is not locked to a value. + + • ‘%V’ + + Like ‘%v’, but the string is prefixed with a space, unless it + is an empty string. + + • ‘%t’ + + The top-level directory of the working tree of the repository, + or if ‘magit-uniquify-buffer-names’ is non-nil an abbreviation + of that. + + • ‘%x’ + + If ‘magit-uniquify-buffer-names’ is nil "*", otherwise the + empty string. Due to limitations of the ‘uniquify’ package, + buffer names must end with the path. + + The value should always contain ‘%m’ or ‘%M’, ‘%v’ or ‘%V’, and + ‘%t’. If ‘magit-uniquify-buffer-names’ is non-nil, then the value + must end with ‘%t’ or ‘%t%x’. See issue #2841. + +User Option: magit-uniquify-buffer-names + This option controls whether the names of Magit buffers are + uniquified. If the names are not being uniquified, then they + contain the full path of the top-level of the working tree of the + corresponding repository. If they are being uniquified, then they + end with the basename of the top-level, or if that would conflict + with the name used for other buffers, then the names of all these + buffers are adjusted until they no longer conflict. + + This is done using the ‘uniquify’ package; customize its options to + control how buffer names are uniquified. + + +File: doc5khxAZ.info, Node: Quitting Windows, Next: Automatic Refreshing of Magit Buffers, Prev: Naming Buffers, Up: Modes and Buffers + +4.1.3 Quitting Windows +---------------------- + +Key: q (magit-mode-bury-buffer) + This command buries or kills the current Magit buffer. The + function specified by option ‘magit-bury-buffer-function’ is used + to bury the buffer when called without a prefix argument or to kill + it when called with a single prefix argument. + + When called with two or more prefix arguments then it always kills + all Magit buffers, associated with the current project, including + the current buffer. + +User Option: magit-bury-buffer-function + The function used to actually bury or kill the current buffer. + + ‘magit-mode-bury-buffer’ calls this function with one argument. If + the argument is non-nil, then the function has to kill the current + buffer. Otherwise it has to bury it alive. The default value + currently is ‘magit-mode-quit-window’. + +Function: magit-restore-window-configuration kill-buffer + Bury or kill the current buffer using ‘quit-window’, which is + called with KILL-BUFFER as first and the selected window as second + argument. + + Then restore the window configuration that existed right before the + current buffer was displayed in the selected frame. Unfortunately + that also means that point gets adjusted in all the buffers, which + are being displayed in the selected frame. + +Function: magit-mode-quit-window kill-buffer + Bury or kill the current buffer using ‘quit-window’, which is + called with KILL-BUFFER as first and the selected window as second + argument. + + Then, if the window was originally created to display a Magit + buffer and the buried buffer was the last remaining Magit buffer + that was ever displayed in the window, then that is deleted. + + +File: doc5khxAZ.info, Node: Automatic Refreshing of Magit Buffers, Next: Automatic Saving of File-Visiting Buffers, Prev: Quitting Windows, Up: Modes and Buffers + +4.1.4 Automatic Refreshing of Magit Buffers +------------------------------------------- + +After running a command which may change the state of the current +repository, the current Magit buffer and the corresponding status buffer +are refreshed. The status buffer can be automatically refreshed +whenever a buffer is saved to a file inside the respective repository by +adding a hook, like so: + + (with-eval-after-load 'magit-mode + (add-hook 'after-save-hook 'magit-after-save-refresh-status t)) + + Automatically refreshing Magit buffers ensures that the displayed +information is up-to-date most of the time but can lead to a noticeable +delay in big repositories. Other Magit buffers are not refreshed to +keep the delay to a minimum and also because doing so can sometimes be +undesirable. + + Buffers can also be refreshed explicitly, which is useful in buffers +that weren’t current during the last refresh and after changes were made +to the repository outside of Magit. + +Key: g (magit-refresh) + This command refreshes the current buffer if its major mode derives + from ‘magit-mode’ as well as the corresponding status buffer. + + If the option ‘magit-revert-buffers’ calls for it, then it also + reverts all unmodified buffers that visit files being tracked in + the current repository. + +Key: G (magit-refresh-all) + This command refreshes all Magit buffers belonging to the current + repository and also reverts all unmodified buffers that visit files + being tracked in the current repository. + + The file-visiting buffers are always reverted, even if + ‘magit-revert-buffers’ is nil. + +User Option: magit-refresh-buffer-hook + This hook is run in each Magit buffer that was refreshed during the + current refresh - normally the current buffer and the status + buffer. + +User Option: magit-refresh-status-buffer + When this option is non-nil, then the status buffer is + automatically refreshed after running git for side-effects, in + addition to the current Magit buffer, which is always refreshed + automatically. + + Only set this to nil after exhausting all other options to improve + performance. + +Function: magit-after-save-refresh-status + This function is intended to be added to ‘after-save-hook’. After + doing that the corresponding status buffer is refreshed whenever a + buffer is saved to a file inside a repository. + + Note that refreshing a Magit buffer is done by re-creating its + contents from scratch, which can be slow in large repositories. If + you are not satisfied with Magit’s performance, then you should + obviously not add this function to that hook. + + +File: doc5khxAZ.info, Node: Automatic Saving of File-Visiting Buffers, Next: Automatic Reverting of File-Visiting Buffers, Prev: Automatic Refreshing of Magit Buffers, Up: Modes and Buffers + +4.1.5 Automatic Saving of File-Visiting Buffers +----------------------------------------------- + +File-visiting buffers are by default saved at certain points in time. +This doesn’t guarantee that Magit buffers are always up-to-date, but, +provided one only edits files by editing them in Emacs and uses only +Magit to interact with Git, one can be fairly confident. When in doubt +or after outside changes, type ‘g’ (‘magit-refresh’) to save and refresh +explicitly. + +User Option: magit-save-repository-buffers + This option controls whether file-visiting buffers are saved before + certain events. + + If this is non-nil then all modified file-visiting buffers + belonging to the current repository may be saved before running + commands, before creating new Magit buffers, and before explicitly + refreshing such buffers. If this is ‘dontask’ then this is done + without user intervention. If it is ‘t’ then the user has to + confirm each save. + + +File: doc5khxAZ.info, Node: Automatic Reverting of File-Visiting Buffers, Prev: Automatic Saving of File-Visiting Buffers, Up: Modes and Buffers + +4.1.6 Automatic Reverting of File-Visiting Buffers +-------------------------------------------------- + +By default Magit automatically reverts buffers that are visiting files +that are being tracked in a Git repository, after they have changed on +disk. When using Magit one often changes files on disk by running Git, +i.e., "outside Emacs", making this a rather important feature. + + For example, if you discard a change in the status buffer, then that +is done by running ‘git apply --reverse ...’, and Emacs considers the +file to have "changed on disk". If Magit did not automatically revert +the buffer, then you would have to type ‘M-x revert-buffer RET RET’ in +the visiting buffer before you could continue making changes. + +User Option: magit-auto-revert-mode + When this mode is enabled, then buffers that visit tracked files + are automatically reverted after the visited files change on disk. + +User Option: global-auto-revert-mode + When this mode is enabled, then any file-visiting buffer is + automatically reverted after the visited file changes on disk. + + If you like buffers that visit tracked files to be automatically + reverted, then you might also like any buffer to be reverted, not + just those visiting tracked files. If that is the case, then + enable this mode _instead of_ ‘magit-auto-revert-mode’. + +User Option: magit-auto-revert-immediately + This option controls whether Magit reverts buffers immediately. + + If this is non-nil and either ‘global-auto-revert-mode’ or + ‘magit-auto-revert-mode’ is enabled, then Magit immediately reverts + buffers by explicitly calling ‘auto-revert-buffers’ after running + Git for side-effects. + + If ‘auto-revert-use-notify’ is non-nil (and file notifications are + actually supported), then ‘magit-auto-revert-immediately’ does not + have to be non-nil, because the reverts happen immediately anyway. + + If ‘magit-auto-revert-immediately’ and ‘auto-revert-use-notify’ are + both ‘nil’, then reverts happen after ‘auto-revert-interval’ + seconds of user inactivity. That is not desirable. + +User Option: auto-revert-use-notify + This option controls whether file notification functions should be + used. Note that this variable unfortunately defaults to ‘t’ even + on systems on which file notifications cannot be used. + +User Option: magit-auto-revert-tracked-only + This option controls whether ‘magit-auto-revert-mode’ only reverts + tracked files or all files that are located inside Git + repositories, including untracked files and files located inside + Git’s control directory. + +User Option: auto-revert-mode + The global mode ‘magit-auto-revert-mode’ works by turning on this + local mode in the appropriate buffers (but + ‘global-auto-revert-mode’ is implemented differently). You can + also turn it on or off manually, which might be necessary if Magit + does not notice that a previously untracked file now is being + tracked or vice-versa. + +User Option: auto-revert-stop-on-user-input + This option controls whether the arrival of user input suspends the + automatic reverts for ‘auto-revert-interval’ seconds. + +User Option: auto-revert-interval + This option controls how many seconds Emacs waits for before + resuming suspended reverts. + +User Option: auto-revert-buffer-list-filter + This option specifies an additional filter used by + ‘auto-revert-buffers’ to determine whether a buffer should be + reverted or not. + + This option is provided by Magit, which also advises + ‘auto-revert-buffers’ to respect it. Magit users who do not turn + on the local mode ‘auto-revert-mode’ themselves, are best served by + setting the value to ‘magit-auto-revert-repository-buffer-p’. + + However the default is nil, so as not to disturb users who do use + the local mode directly. If you experience delays when running + Magit commands, then you should consider using one of the + predicates provided by Magit - especially if you also use Tramp. + + Users who do turn on ‘auto-revert-mode’ in buffers in which Magit + doesn’t do that for them, should likely not use any filter. Users + who turn on ‘global-auto-revert-mode’, do not have to worry about + this option, because it is disregarded if the global mode is + enabled. + +User Option: auto-revert-verbose + This option controls whether Emacs reports when a buffer has been + reverted. + + The options with the ‘auto-revert-’ prefix are located in the Custom +group named ‘auto-revert’. The other, Magit-specific, options are +located in the ‘magit’ group. + +* Menu: + +* Risk of Reverting Automatically:: + + +File: doc5khxAZ.info, Node: Risk of Reverting Automatically, Up: Automatic Reverting of File-Visiting Buffers + +Risk of Reverting Automatically +............................... + +For the vast majority of users, automatically reverting file-visiting +buffers after they have changed on disk is harmless. + + If a buffer is modified (i.e., it contains changes that haven’t been +saved yet), then Emacs will refuse to automatically revert it. If you +save a previously modified buffer, then that results in what is seen by +Git as an uncommitted change. Git will then refuse to carry out any +commands that would cause these changes to be lost. In other words, if +there is anything that could be lost, then either Git or Emacs will +refuse to discard the changes. + + However, if you use file-visiting buffers as a sort of ad hoc +"staging area", then the automatic reverts could potentially cause data +loss. So far I have heard from only one user who uses such a workflow. + + An example: You visit some file in a buffer, edit it, and save the +changes. Then, outside of Emacs (or at least not using Magit or by +saving the buffer) you change the file on disk again. At this point the +buffer is the only place where the intermediate version still exists. +You have saved the changes to disk, but that has since been overwritten. +Meanwhile Emacs considers the buffer to be unmodified (because you have +not made any changes to it since you last saved it to the visited file) +and therefore would not object to it being automatically reverted. At +this point an Auto-Revert mode would kick in. It would check whether +the buffer is modified and since that is not the case it would revert +it. The intermediate version would be lost. (Actually you could still +get it back using the ‘undo’ command.) + + If your workflow depends on Emacs preserving the intermediate version +in the buffer, then you have to disable all Auto-Revert modes. But +please consider that such a workflow would be dangerous even without +using an Auto-Revert mode, and should therefore be avoided. If Emacs +crashes or if you quit Emacs by mistake, then you would also lose the +buffer content. There would be no autosave file still containing the +intermediate version (because that was deleted when you saved the +buffer) and you would not be asked whether you want to save the buffer +(because it isn’t modified). + + +File: doc5khxAZ.info, Node: Sections, Next: Transient Commands, Prev: Modes and Buffers, Up: Interface Concepts + +4.2 Sections +============ + +Magit buffers are organized into nested sections, which can be collapsed +and expanded, similar to how sections are handled in Org mode. Each +section also has a type, and some sections also have a value. For each +section type there can also be a local keymap, shared by all sections of +that type. + + Taking advantage of the section value and type, many commands operate +on the current section, or when the region is active and selects +sections of the same type, all of the selected sections. Commands that +only make sense for a particular section type (as opposed to just +behaving differently depending on the type) are usually bound in section +type keymaps. + +* Menu: + +* Section Movement:: +* Section Visibility:: +* Section Hooks:: +* Section Types and Values:: +* Section Options:: + + +File: doc5khxAZ.info, Node: Section Movement, Next: Section Visibility, Up: Sections + +4.2.1 Section Movement +---------------------- + +To move within a section use the usual keys (‘C-p’, ‘C-n’, ‘C-b’, ‘C-f’ +etc), whose global bindings are not shadowed. To move to another +section use the following commands. + + The section movement commands described here run the hook +‘magit-section-movement-hook’. Note that they explicitly run that hook +and that aribrary other movement, defined in Emacs and other packages, +do not run that hook. That hook, and hook functions that can be added +to it, or are part of its default value, are described below. + +Key: p (magit-section-backward) + When not at the beginning of a section, then move to the beginning + of the current section. At the beginning of a section, instead + move to the beginning of the previous visible section. + +Key: n (magit-section-forward) + Move to the beginning of the next visible section. + +Key: M-p (magit-section-backward-siblings) + Move to the beginning of the previous sibling section. If there is + no previous sibling section, then move to the parent section + instead. + +Key: M-n (magit-section-forward-siblings) + Move to the beginning of the next sibling section. If there is no + next sibling section, then move to the parent section instead. + +Key: ^ (magit-section-up) + Move to the beginning of the parent of the current section. + + The above commands all call the hook ‘magit-section-movement-hook’. +Any of the functions listed below can be used as members of this hook. + + You might want to remove some of the functions that Magit adds using +‘add-hook’. In doing so you have to make sure you do not attempt to +remove function that haven’t even been added yet, for example: + + (with-eval-after-load 'magit-diff + (remove-hook 'magit-section-movement-hook + 'magit-hunk-set-window-start)) + +Variable: magit-section-movement-hook + This hook is run by all of the above section movement commands, + after arriving at the destination. It is *not* run by arbitrary + other movement commands (such as ‘next-line’), which are provided + by Emacs or third-party packages. + +Function: magit-hunk-set-window-start + This hook function ensures that the beginning of the current + section is visible, provided it is a ‘hunk’ section. Otherwise, it + does nothing. + + Loading ‘magit-diff’ adds this function to the hook. + +Function: magit-section-set-window-start + This hook function ensures that the beginning of the current + section is visible, regardless of the section’s type. If you add + this to ‘magit-section-movement-hook’, then you must remove the + hunk-only variant in turn. + +Function: magit-log-maybe-show-more-commits + This hook function only has an effect in log buffers, and ‘point’ + is on the "show more" section. If that is the case, then it + doubles the number of commits that are being shown. + + Loading ‘magit-log’ adds this function to the hook. + +Function: magit-log-maybe-update-revision-buffer + When moving inside a log buffer, then this function updates the + revision buffer, provided it is already being displayed in another + window of the same frame. + + Loading ‘magit-log’ adds this function to the hook. + +Function: magit-log-maybe-update-blob-buffer + When moving inside a log buffer and another window of the same + frame displays a blob buffer, then this function instead displays + the blob buffer for the commit at point in that window. + +Function: magit-status-maybe-update-revision-buffer + When moving inside a status buffer, then this function updates the + revision buffer, provided it is already being displayed in another + window of the same frame. + +Function: magit-status-maybe-update-stash-buffer + When moving inside a status buffer, then this function updates the + stash buffer, provided it is already being displayed in another + window of the same frame. + +Function: magit-status-maybe-update-blob-buffer + When moving inside a status buffer and another window of the same + frame displays a blob buffer, then this function instead displays + the blob buffer for the commit at point in that window. + +Function: magit-stashes-maybe-update-stash-buffer + When moving inside a buffer listing stashes, then this function + updates the stash buffer, provided it is already being displayed in + another window of the same frame. + +User Option: magit-update-other-window-delay + Delay before automatically updating the other window. + + When moving around in certain buffers using Magit’s own section + movement commands (but not other movement commands), then certain + other buffers, which are being displayed in another window, may + optionally be updated to display information about the section at + point. + + When holding down a key to move by more than just one section, then + that would update that buffer for each section on the way. To + prevent that, updating the revision buffer is delayed, and this + option controls for how long. For optimal experience you might + have to adjust this delay and/or the keyboard repeat rate and delay + of your graphical environment or operating system. + + +File: doc5khxAZ.info, Node: Section Visibility, Next: Section Hooks, Prev: Section Movement, Up: Sections + +4.2.2 Section Visibility +------------------------ + +Magit provides many commands for changing the visibility of sections, +but all you need to get started are the next two. + +Key: TAB (magit-section-toggle) + Toggle the visibility of the body of the current section. + +Key: C-c TAB (magit-section-cycle) + +Key: C- (magit-section-cycle) + Cycle the visibility of current section and its children. + + If this command is invoked using ‘C-’ and that is globally + bound to ‘tab-next’, then this command pivots to behave like that + command, and you must instead use ‘C-c TAB’ to cycle section + visibility. + + If you would like to keep using ‘C-’ to cycle section + visibility but also want to use ‘tab-bar-mode’, then you have to + prevent that mode from using this key and instead bind another key + to ‘tab-next’. Because ‘tab-bar-mode’ does not use a mode map but + instead manipulates the global map, this involves advising + ‘tab-bar--define-keys’. + +Key: M- (magit-section-cycle-diffs) + Cycle the visibility of diff-related sections in the current + buffer. + +Key: S- (magit-section-cycle-global) + Cycle the visibility of all sections in the current buffer. + +Key: 1 (magit-section-show-level-1) + +Key: 2 (magit-section-show-level-2) + +Key: 3 (magit-section-show-level-3) + +Key: 4 (magit-section-show-level-4) + Show sections surrounding the current section up to level N. + +Key: M-1 (magit-section-show-level-1-all) + +Key: M-2 (magit-section-show-level-2-all) + +Key: M-3 (magit-section-show-level-3-all) + +Key: M-4 (magit-section-show-level-4-all) + Show all sections up to level N. + + Some functions, which are used to implement the above commands, are +also exposed as commands themselves. By default no keys are bound to +these commands, as they are generally perceived to be much less useful. +But your mileage may vary. + +Command: magit-section-show + Show the body of the current section. + +Command: magit-section-hide + Hide the body of the current section. + +Command: magit-section-show-headings + Recursively show headings of children of the current section. Only + show the headings. Previously shown text-only bodies are hidden. + +Command: magit-section-show-children + Recursively show the bodies of children of the current section. + With a prefix argument show children down to the level of the + current section, and hide deeper children. + +Command: magit-section-hide-children + Recursively hide the bodies of children of the current section. + +Command: magit-section-toggle-children + Toggle visibility of bodies of children of the current section. + + When a buffer is first created then some sections are shown expanded +while others are not. This is hard coded. When a buffer is refreshed +then the previous visibility is preserved. The initial visibility of +certain sections can also be overwritten using the hook +‘magit-section-set-visibility-hook’. + +User Option: magit-section-initial-visibility-alist + This options can be used to override the initial visibility of + sections. In the future it will also be used to define the + defaults, but currently a section’s default is still hardcoded. + + The value is an alist. Each element maps a section type or lineage + to the initial visibility state for such sections. The state has + to be one of ‘show’ or ‘hide’, or a function that returns one of + these symbols. A function is called with the section as the only + argument. + + Use the command ‘magit-describe-section-briefly’ to determine a + section’s lineage or type. The vector in the output is the section + lineage and the type is the first element of that vector. + Wildcards can be used, see ‘magit-section-match’. + +User Option: magit-section-cache-visibility + This option controls for which sections the previous visibility + state should be restored if a section disappears and later appears + again. The value is a boolean or a list of section types. If t, + then the visibility of all sections is cached. Otherwise this is + only done for sections whose type matches one of the listed types. + + This requires that the function ‘magit-section-cached-visibility’ + is a member of ‘magit-section-set-visibility-hook’. + +Variable: magit-section-set-visibility-hook + This hook is run when first creating a buffer and also when + refreshing an existing buffer, and is used to determine the + visibility of the section currently being inserted. + + Each function is called with one argument, the section being + inserted. It should return ‘hide’ or ‘show’, or to leave the + visibility undefined ‘nil’. If no function decides on the + visibility and the buffer is being refreshed, then the visibility + is preserved; or if the buffer is being created, then the hard + coded default is used. + + Usually this should only be used to set the initial visibility but + not during refreshes. If ‘magit-insert-section--oldroot’ is + non-nil, then the buffer is being refreshed and these functions + should immediately return ‘nil’. + +User Option: magit-section-visibility-indicator + This option controls whether and how to indicate that a section can + be expanded/collapsed. + + If nil, then no visibility indicators are shown. Otherwise the + value has to have one of these two forms: + + • ‘(EXPANDABLE-BITMAP . COLLAPSIBLE-BITMAP)’ + + Both values have to be variables whose values are fringe + bitmaps. In this case every section that can be expanded or + collapsed gets an indicator in the left fringe. + + To provide extra padding around the indicator, set + ‘left-fringe-width’ in ‘magit-mode-hook’, e.g.: + + (add-hook 'magit-mode-hook (lambda () + (setq left-fringe-width 20))) + + • ‘(STRING . BOOLEAN)’ + + In this case STRING (usually an ellipsis) is shown at the end + of the heading of every collapsed section. Expanded sections + get no indicator. The cdr controls whether the appearance of + these ellipsis take section highlighting into account. Doing + so might potentially have an impact on performance, while not + doing so is kinda ugly. + + +File: doc5khxAZ.info, Node: Section Hooks, Next: Section Types and Values, Prev: Section Visibility, Up: Sections + +4.2.3 Section Hooks +------------------- + +Which sections are inserted into certain buffers is controlled with +hooks. This includes the status and the refs buffers. For other +buffers, e.g., log and diff buffers, this is not possible. The command +‘magit-describe-section’ can be used to see which hook (if any) was +responsible for inserting the section at point. + + For buffers whose sections can be customized by the user, a hook +variable called ‘magit-TYPE-sections-hook’ exists. This hook should be +changed using ‘magit-add-section-hook’. Avoid using ‘add-hooks’ or the +Custom interface. + + The various available section hook variables are described later in +this manual along with the appropriate "section inserter functions". + +Function: magit-add-section-hook hook function &optional at append local + Add the function FUNCTION to the value of section hook HOOK. + + Add FUNCTION at the beginning of the hook list unless optional + APPEND is non-nil, in which case FUNCTION is added at the end. If + FUNCTION already is a member then move it to the new location. + + If optional AT is non-nil and a member of the hook list, then add + FUNCTION next to that instead. Add before or after AT, or replace + AT with FUNCTION depending on APPEND. If APPEND is the symbol + ‘replace’, then replace AT with FUNCTION. For any other non-nil + value place FUNCTION right after AT. If nil, then place FUNCTION + right before AT. If FUNCTION already is a member of the list but + AT is not, then leave FUNCTION where ever it already is. + + If optional LOCAL is non-nil, then modify the hook’s buffer-local + value rather than its global value. This makes the hook local by + copying the default value. That copy is then modified. + + HOOK should be a symbol. If HOOK is void, it is first set to nil. + HOOK’s value must not be a single hook function. FUNCTION should + be a function that takes no arguments and inserts one or multiple + sections at point, moving point forward. FUNCTION may choose not + to insert its section(s), when doing so would not make sense. It + should not be abused for other side-effects. + + To remove a function from a section hook, use ‘remove-hook’. + + +File: doc5khxAZ.info, Node: Section Types and Values, Next: Section Options, Prev: Section Hooks, Up: Sections + +4.2.4 Section Types and Values +------------------------------ + +Each section has a type, for example ‘hunk’, ‘file’, and ‘commit’. +Instances of certain section types also have a value. The value of a +section of type ‘file’, for example, is a file name. + + Users usually do not have to worry about a section’s type and value, +but knowing them can be handy at times. + +Key: H (magit-describe-section) + This command shows information about the section at point in a + separate buffer. + +Command: magit-describe-section-briefly + This command shows information about the section at point in the + echo area, as ‘#’. + + Many commands behave differently depending on the type of the section +at point and/or somehow consume the value of that section. But that is +only one of the reasons why the same key may do something different, +depending on what section is current. + + Additionally for each section type a keymap *might* be defined, named +‘magit-TYPE-section-map’. That keymap is used as text property keymap +of all text belonging to any section of the respective type. If such a +map does not exist for a certain type, then you can define it yourself, +and it will automatically be used. + + +File: doc5khxAZ.info, Node: Section Options, Prev: Section Types and Values, Up: Sections + +4.2.5 Section Options +--------------------- + +This section describes options that have an effect on more than just a +certain type of sections. As you can see there are not many of those. + +User Option: magit-section-show-child-count + Whether to append the number of children to section headings. This + only affects sections that could benefit from this information. + + +File: doc5khxAZ.info, Node: Transient Commands, Next: Transient Arguments and Buffer Variables, Prev: Sections, Up: Interface Concepts + +4.3 Transient Commands +====================== + +Many Magit commands are implemented as *transient* commands. First the +user invokes a *prefix* command, which causes its *infix* arguments and +*suffix* commands to be displayed in the echo area. The user then +optionally sets some infix arguments and finally invokes one of the +suffix commands. + + This is implemented in the library ‘transient’. Earlier Magit +releases used the package ‘magit-popup’ and even earlier versions +library ‘magit-key-mode’. + + Transient is documented in *note (transient)Top::. + +Key: C-x M-g (magit-dispatch) + +Key: C-c g (magit-dispatch) + This transient prefix command binds most of Magit’s other prefix + commands as suffix commands and displays them in a temporary buffer + until one of them is invoked. Invoking such a sub-prefix causes + the suffixes of that command to be bound and displayed instead of + those of ‘magit-dispatch’. + + This command is also, or especially, useful outside Magit buffers, + so Magit by default binds it to ‘C-c M-g’ in the global keymap. + ‘C-c g’ would be a better binding, but we cannot use that by + default, because that key sequence is reserved for the user. See + *note Global Bindings:: to learn more default and recommended key + bindings. + + +File: doc5khxAZ.info, Node: Transient Arguments and Buffer Variables, Next: Completion Confirmation and the Selection, Prev: Transient Commands, Up: Interface Concepts + +4.4 Transient Arguments and Buffer Variables +============================================ + +The infix arguments of many of Magit’s transient prefix commands cease +to have an effect once the ‘git’ command that is called with those +arguments has returned. Commands that create a commit are a good +example for this. If the user changes the arguments, then that only +affects the next invocation of a suffix command. If the same transient +prefix command is later invoked again, then the arguments are initially +reset to the default value. This default value can be set for the +current Emacs session or saved permanently, see *note (transient)Saving +Values::. It is also possible to cycle through previously used sets of +arguments using ‘C-M-p’ and ‘C-M-n’, see *note (transient)Using +History::. + + However the infix arguments of many other transient commands continue +to have an effect even after the ‘git’ command that was called with +those arguments has returned. The most important commands like this are +those that display a diff or log in a dedicated buffer. Their arguments +obviously continue to have an effect for as long as the respective diff +or log is being displayed. Furthermore the used arguments are stored in +buffer-local variables for future reference. + + For commands in the second group it isn’t always desirable to reset +their arguments to the global value when the transient prefix command is +invoked again. + + As mentioned above, it is possible to cycle through previously used +sets of arguments while a transient popup is visible. That means that +we could always reset the infix arguments to the default because the set +of arguments that is active in the existing buffer is only a few ‘C-M-p’ +away. Magit can be configured to behave like that, but because I expect +that most users would not find that very convenient, it is not the +default. + + Also note that it is possible to change the diff and log arguments +used in the current buffer (including the status buffer, which contains +both diff and log sections) using the respective "refresh" transient +prefix commands on ‘D’ and ‘L’. (‘d’ and ‘l’ on the other hand are +intended to change *what* diff or log is being displayed. It is +possible to also change *how* the diff or log is being displayed at the +same time, but if you only want to do the latter, then you should use +the refresh variants.) Because these secondary diff and log transient +prefixes are about *changing* the arguments used in the current buffer, +they *always* start out with the set of arguments that are currently in +effect in that buffer. + + Some commands are usually invoked directly even though they can also +be invoked as the suffix of a transient prefix command. Most +prominently ‘magit-show-commit’ is usually invoked by typing ‘RET’ while +point is on a commit in a log, but it can also be invoked from the +‘magit-diff’ transient prefix. + + When such a command is invoked directly, then it is important to +reuse the arguments as specified by the respective buffer-local values, +instead of using the default arguments. Imagine you press ‘RET’ in a +log to display the commit at point in a different buffer and then use +‘D’ to change how the diff is displayed in that buffer. And then you +press ‘RET’ on another commit to show that instead and the diff +arguments are reset to the default. Not cool; so Magit does not do that +by default. + +User Option: magit-prefix-use-buffer-arguments + This option controls whether the infix arguments initially shown in + certain transient prefix commands are based on the arguments that + are currently in effect in the buffer that their suffixes update. + + The ‘magit-diff’ and ‘magit-log’ transient prefix commands are + affected by this option. + +User Option: magit-direct-use-buffer-arguments + This option controls whether certain commands, when invoked + directly (i.e., not as the suffix of a transient prefix command), + use the arguments that are currently active in the buffer that they + are about to update. The alternative is to use the default value + for these arguments, which might change the arguments that are used + in the buffer. + +Valid values for both of the above options are: + + • ‘always’: Always use the set of arguments that is currently active + in the respective buffer, provided that buffer exists of course. + • ‘selected’ or ‘t’: Use the set of arguments from the respective + buffer, but only if it is displayed in a window of the current + frame. This is the default for both variables. + • ‘current’: Use the set of arguments from the respective buffer, but + only if it is the current buffer. + • ‘never’: Never use the set of arguments from the respective buffer. + +I am afraid it gets more complicated still: + + • The global diff and log arguments are set for each supported mode + individually. The diff arguments for example have different values + in ‘magit-diff-mode’, ‘magit-revision-mode’, + ‘magit-merge-preview-mode’ and ‘magit-status-mode’ buffers. + Setting or saving the value for one mode does not change the value + for other modes. The history however is shared. + + • When ‘magit-show-commit’ is invoked directly from a log buffer, + then the file filter is picked up from that buffer, not from the + revision buffer or the mode’s global diff arguments. + + • Even though they are suffixes of the diff prefix + ‘magit-show-commit’ and ‘magit-stash-show’ do not use the diff + buffer used by the diff commands, instead they use the dedicated + revision and stash buffers. + + At the time you invoke the diff prefix it is unknown to Magit which + of the suffix commands you are going to invoke. While not certain, + more often than not users invoke one of the commands that use the + diff buffer, so the initial infix arguments are those used in that + buffer. However if you invoke one of these commands directly, then + Magit knows that it should use the arguments from the revision + resp. stash buffer. + + • The log prefix also features reflog commands, but these commands do + not use the log arguments. + + • If ‘magit-show-refs’ is invoked from a ‘magit-refs-mode’ buffer, + then it acts as a refresh prefix and therefore unconditionally uses + the buffer’s arguments as initial arguments. If it is invoked + elsewhere with a prefix argument, then it acts as regular prefix + and therefore respects ‘magit-prefix-use-buffer-arguments’. If it + is invoked elsewhere without a prefix argument, then it acts as a + direct command and therefore respects + ‘magit-direct-use-buffer-arguments’. + + +File: doc5khxAZ.info, Node: Completion Confirmation and the Selection, Next: Mouse Support, Prev: Transient Arguments and Buffer Variables, Up: Interface Concepts + +4.5 Completion, Confirmation and the Selection +============================================== + +* Menu: + +* Action Confirmation:: +* Completion and Confirmation:: +* The Selection:: +* The hunk-internal region:: +* Support for Completion Frameworks:: +* Additional Completion Options:: + + +File: doc5khxAZ.info, Node: Action Confirmation, Next: Completion and Confirmation, Up: Completion Confirmation and the Selection + +4.5.1 Action Confirmation +------------------------- + +By default many actions that could potentially lead to data loss have to +be confirmed. This includes many very common actions, so this can +quickly become annoying. Many of these actions can be undone and if you +have thought about how to undo certain mistakes, then it should be safe +to disable confirmation for the respective actions. + + The option ‘magit-no-confirm’ can be used to tell Magit to perform +certain actions without the user having to confirm them. Note that +while this option can only be used to disable confirmation for a +specific set of actions, the next section explains another way of +telling Magit to ask fewer questions. + +User Option: magit-no-confirm + The value of this option is a list of symbols, representing actions + that do not have to be confirmed by the user before being carried + out. + + By default many potentially dangerous commands ask the user for + confirmation. Each of the below symbols stands for an action + which, when invoked unintentionally or without being fully aware of + the consequences, could lead to tears. In many cases there are + several commands that perform variations of a certain action, so we + don’t use the command names but more generic symbols. + + • Applying changes: + + • ‘discard’ Discarding one or more changes (i.e., hunks or + the complete diff for a file) loses that change, + obviously. + + • ‘reverse’ Reverting one or more changes can usually be + undone by reverting the reversion. + + • ‘stage-all-changes’, ‘unstage-all-changes’ When there are + both staged and unstaged changes, then un-/staging + everything would destroy that distinction. Of course + that also applies when un-/staging a single change, but + then less is lost and one does that so often that having + to confirm every time would be unacceptable. + + • Files: + + • ‘delete’ When a file that isn’t yet tracked by Git is + deleted, then it is completely lost, not just the last + changes. Very dangerous. + + • ‘trash’ Instead of deleting a file it can also be move to + the system trash. Obviously much less dangerous than + deleting it. + + Also see option ‘magit-delete-by-moving-to-trash’. + + • ‘resurrect’ A deleted file can easily be resurrected by + "deleting" the deletion, which is done using the same + command that was used to delete the same file in the + first place. + + • ‘untrack’ Untracking a file can be undone by tracking it + again. + + • ‘rename’ Renaming a file can easily be undone. + + • Sequences: + + • ‘reset-bisect’ Aborting (known to Git as "resetting") a + bisect operation loses all information collected so far. + + • ‘abort-cherry-pick’ Aborting a cherry-pick throws away + all conflict resolutions which have already been carried + out by the user. + + • ‘abort-revert’ Aborting a revert throws away all conflict + resolutions which have already been carried out by the + user. + + • ‘abort-rebase’ Aborting a rebase throws away all already + modified commits, but it’s possible to restore those from + the reflog. + + • ‘abort-merge’ Aborting a merge throws away all conflict + resolutions which have already been carried out by the + user. + + • ‘merge-dirty’ Merging with a dirty worktree can make it + hard to go back to the state before the merge was + initiated. + + • References: + + • ‘delete-unmerged-branch’ Once a branch has been deleted, + it can only be restored using low-level recovery tools + provided by Git. And even then the reflog is gone. The + user always has to confirm the deletion of a branch by + accepting the default choice (or selecting another + branch), but when a branch has not been merged yet, also + make sure the user is aware of that. + + • ‘delete-pr-remote’ When deleting a branch that was + created from a pull-request and if no other branches + still exist on that remote, then ‘magit-branch-delete’ + offers to delete the remote as well. This should be safe + because it only happens if no other refs exist in the + remotes namespace, and you can recreate the remote if + necessary. + + • ‘drop-stashes’ Dropping a stash is dangerous because Git + stores stashes in the reflog. Once a stash is removed, + there is no going back without using low-level recovery + tools provided by Git. When a single stash is dropped, + then the user always has to confirm by accepting the + default (or selecting another). This action only + concerns the deletion of multiple stashes at once. + + • Publishing: + + • ‘set-and-push’ When pushing to the upstream or the + push-remote and that isn’t actually configured yet, then + the user can first set the target. If s/he confirms the + default too quickly, then s/he might end up pushing to + the wrong branch and if the remote repository is + configured to disallow fixing such mistakes, then that + can be quite embarrassing and annoying. + + • Edit published history: + + Without adding these symbols here, you will be warned before + editing commits that have already been pushed to one of the + branches listed in ‘magit-published-branches’. + + • ‘amend-published’ Affects most commands that amend to + "HEAD". + + • ‘rebase-published’ Affects commands that perform + interactive rebases. This includes commands from the + commit transient that modify a commit other than "HEAD", + namely the various fixup and squash variants. + + • ‘edit-published’ Affects the commands + ‘magit-edit-line-commit’ and + ‘magit-diff-edit-hunk-commit’. These two commands make + it quite easy to accidentally edit a published commit, so + you should think twice before configuring them not to ask + for confirmation. + + To disable confirmation completely, add all three symbols here + or set ‘magit-published-branches’ to ‘nil’. + + • Various: + + • ‘stash-apply-3way’ When a stash cannot be applied using + ‘git stash apply’, then Magit uses ‘git apply’ instead, + possibly using the ‘--3way’ argument, which isn’t always + perfectly safe. See also ‘magit-stash-apply’. + + • ‘kill-process’ There seldom is a reason to kill a + process. + + • Global settings: + + Instead of adding all of the above symbols to the value of + this option, you can also set it to the atom ‘t’, which has + the same effect as adding all of the above symbols. Doing + that most certainly is a bad idea, especially because other + symbols might be added in the future. So even if you don’t + want to be asked for confirmation for any of these actions, + you are still better of adding all of the respective symbols + individually. + + When ‘magit-wip-before-change-mode’ is enabled, then the + following actions can be undone fairly easily: ‘discard’, + ‘reverse’, ‘stage-all-changes’, and ‘unstage-all-changes’. If + and only if this mode is enabled, then ‘safe-with-wip’ has the + same effect as adding all of these symbols individually. + + +File: doc5khxAZ.info, Node: Completion and Confirmation, Next: The Selection, Prev: Action Confirmation, Up: Completion Confirmation and the Selection + +4.5.2 Completion and Confirmation +--------------------------------- + +Many Magit commands ask the user to select from a list of possible +things to act on, while offering the most likely choice as the default. +For many of these commands the default is the thing at point, provided +that it actually is a valid thing to act on. For many commands that act +on a branch, the current branch serves as the default if there is no +branch at point. + + These commands combine asking for confirmation and asking for a +target to act on into a single action. The user can confirm the default +target using ‘RET’ or abort using ‘C-g’. This is similar to a +‘y-or-n-p’ prompt, but the keys to confirm or abort differ. + + At the same time the user is also given the opportunity to select +another target, which is useful because for some commands and/or in some +situations you might want to select the action before selecting the +target by moving to it. + + However you might find that for some commands you always want to use +the default target, if any, or even that you want the command to act on +the default without requiring any confirmation at all. The option +‘magit-dwim-selection’ can be used to configure certain commands to that +effect. + + Note that when the region is active then many commands act on the +things that are selected using a mechanism based on the region, in many +cases after asking for confirmation. This region-based mechanism is +called the "selection" and is described in detail in the next section. +When a selection exists that is valid for the invoked command, then that +command never offers to act on something else, and whether it asks for +confirmation is not controlled by this option. + + Also note that Magit asks for confirmation of certain actions that +are not coupled with completion (or the selection). Such dialogs are +also not affected by this option and are described in the previous +section. + +User Option: magit-dwim-selection + + This option can be used to tell certain commands to use the thing at +point instead of asking the user to select a candidate to act on, with +or without confirmation. + + The value has the form ‘((COMMAND nil|PROMPT DEFAULT)...)’. + + • COMMAND is the command that should not prompt for a choice. To + have an effect, the command has to use the function + ‘magit-completing-read’ or a utility function which in turn uses + that function. + + • If the command uses ‘magit-completing-read’ multiple times, then + PROMPT can be used to only affect one of these uses. PROMPT, if + non-nil, is a regular expression that is used to match against the + PROMPT argument passed to ‘magit-completing-read’. + + • DEFAULT specifies how to use the default. If it is ‘t’, then the + DEFAULT argument passed to ‘magit-completing-read’ is used without + confirmation. If it is ‘ask’, then the user is given a chance to + abort. DEFAULT can also be ‘nil’, in which case the entry has no + effect. + + +File: doc5khxAZ.info, Node: The Selection, Next: The hunk-internal region, Prev: Completion and Confirmation, Up: Completion Confirmation and the Selection + +4.5.3 The Selection +------------------- + +If the region is active, then many Magit commands act on the things that +are selected using a mechanism based on the region instead of one single +thing. When the region is not active, then these commands act on the +thing at point or read a single thing to act on. This is described in +the previous section — this section only covers how multiple things are +selected, how that is visualized, and how certain commands behave when +that is the case. + + Magit’s mechanism for selecting multiple things, or rather sections +that represent these things, is based on the Emacs region, but the area +that Magit considers to be selected is typically larger than the region +and additional restrictions apply. + + Magit makes a distinction between a region that qualifies as forming +a valid Magit selection and a region that does not. If the region does +not qualify, then it is displayed as it is in other Emacs buffers. If +the region does qualify as a Magit selection, then the selection is +always visualized, while the region itself is only visualized if it +begins and ends on the same line. + + For a region to qualify as a Magit selection, it must begin in the +heading of one section and end in the heading of a sibling section. +Note that if the end of the region is at the very beginning of section +heading (i.e., at the very beginning of a line) then that section is +considered to be *inside* the selection. + + This is not consistent with how the region is normally treated in +Emacs — if the region ends at the beginning of a line, then that line is +outside the region. Due to how Magit visualizes the selection, it +should be obvious that this difference exists. + + Not every command acts on every valid selection. Some commands do +not even consider the location of point, others may act on the section +at point but not support acting on the selection, and even commands that +do support the selection of course only do so if it selects things that +they can act on. + + This is the main reason why the selection must include the section at +point. Even if a selection exists, the invoked command may disregard +it, in which case it may act on the current section only. It is much +safer to only act on the current section but not the other selected +sections than it is to act on the current section *instead* of the +selected sections. The latter would be much more surprising and if the +current section always is part of the selection, then that cannot +happen. + +Variable: magit-keep-region-overlay + This variable controls whether the region is visualized as usual + even when a valid Magit selection or a hunk-internal region exists. + See the doc-string for more information. + + +File: doc5khxAZ.info, Node: The hunk-internal region, Next: Support for Completion Frameworks, Prev: The Selection, Up: Completion Confirmation and the Selection + +4.5.4 The hunk-internal region +------------------------------ + +Somewhat related to the Magit selection described in the previous +section is the hunk-internal region. + + Like the selection, the hunk-internal region is based on the Emacs +region but causes that region to not be visualized as it would in other +Emacs buffers, and includes the line on which the region ends even if it +ends at the very beginning of that line. + + Unlike the selection, which is based on a region that must begin in +the heading of one section and ends in the section of a sibling section, +the hunk-internal region must begin inside the *body* of a hunk section +and end in the body of the *same* section. + + The hunk-internal region is honored by "apply" commands, which can, +among other targets, act on a hunk. If the hunk-internal region is +active, then such commands act only on the marked part of the hunk +instead of on the complete hunk. + + +File: doc5khxAZ.info, Node: Support for Completion Frameworks, Next: Additional Completion Options, Prev: The hunk-internal region, Up: Completion Confirmation and the Selection + +4.5.5 Support for Completion Frameworks +--------------------------------------- + +The built-in option ‘completing-read-function’ specifies the low-level +function used by ‘completing-read’ to ask a user to select from a list +of choices. Its default value is ‘completing-read-default’. +Alternative completion frameworks typically activate themselves by +substituting their own implementation. + + Mostly for historic reasons Magit provides a similar option named +‘magit-completing-read-function’, which only controls the low-level +function used by ‘magit-completing-read’. This option also makes it +possible to use a different completing mechanism for Magit than for the +rest of Emacs, but doing that is not recommend. + + You most likely don’t have to customize the magit-specific option to +use an alternative completion framework. For example, if you enable +‘ivy-mode’, then Magit will respect that, and if you enable ‘helm-mode’, +then you are done too. + + However if you want to use Ido, then ‘ido-mode’ won’t do the trick. +You will also have to install the ‘ido-completing-read+’ package and use +‘magit-ido-completing-read’ as ‘magit-completing-read-function’. + +User Option: magit-completing-read-function + The value of this variable is the low-level function used to + perform completion by code that uses ‘magit-completing-read’ (as + opposed to the built-in ‘completing-read’). + + The default value, ‘magit-builtin-completing-read’, is suitable for + the standard completion mechanism, ‘ivy-mode’, and ‘helm-mode’ at + least. + + The built-in ‘completing-read’ and ‘completing-read-default’ are + *not* suitable to be used here. ‘magit-builtin-completing-read’ + performs some additional work, and any function used in its place + has to do the same. + +Function: magit-builtin-completing-read prompt choices &optional predicate require-match initial-input hist def + This function performs completion using the built-in + ‘completing-read’ and does some additional magit-specific work. + +Function: magit-ido-completing-read prompt choices &optional predicate require-match initial-input hist def + This function performs completion using ‘ido-completing-read+’ from + the package by the same name (which you have to explicitly install) + and does some additional magit-specific work. + + We have to use ‘ido-completing-read+’ instead of the + ‘ido-completing-read’ that comes with Ido itself, because the + latter, while intended as a drop-in replacement, cannot serve that + purpose because it violates too many of the implicit conventions. + +Function: magit-completing-read prompt choices &optional predicate require-match initial-input hist def fallback + This is the function that Magit commands use when they need the + user to select a single thing to act on. The arguments have the + same meaning as for ‘completing-read’, except for FALLBACK, which + is unique to this function and is described below. + + Instead of asking the user to choose from a list of possible + candidates, this function may just return the default specified by + DEF, with or without requiring user confirmation. Whether that is + the case depends on PROMPT, ‘this-command’ and + ‘magit-dwim-selection’. See the documentation of the latter for + more information. + + If it does read a value in the minibuffer, then this function acts + similar to ‘completing-read’, except for the following: + + • COLLECTION must be a list of choices. A function is not + supported. + + • If REQUIRE-MATCH is ‘nil’ and the user exits without a choice, + then ‘nil’ is returned instead of an empty string. + + • If REQUIRE-MATCH is non-nil and the users exits without a + choice, an user-error is raised. + + • FALLBACK specifies a secondary default that is only used if + the primary default DEF is ‘nil’. The secondary default is + not subject to ‘magit-dwim-selection’ — if DEF is ‘nil’ but + FALLBACK is not, then this function always asks the user to + choose a candidate, just as if both defaults were ‘nil’. + + • ‘format-prompt’ is called on PROMPT and DEF (or FALLBACK if + DEF is ‘nil’). This appends ": " to the prompt and may also + add the default to the prompt, using the format specified by + ‘minibuffer-default-prompt-format’ and depending on + ‘magit-completing-read-default-prompt-predicate’. + + +File: doc5khxAZ.info, Node: Additional Completion Options, Prev: Support for Completion Frameworks, Up: Completion Confirmation and the Selection + +4.5.6 Additional Completion Options +----------------------------------- + +User Option: magit-list-refs-sortby + For many commands that read a ref or refs from the user, the value + of this option can be used to control the order of the refs. Valid + values include any key accepted by the ‘--sort’ flag of ‘git + for-each-ref’. By default, refs are sorted alphabetically by their + full name (e.g., "refs/heads/master"). + + +File: doc5khxAZ.info, Node: Mouse Support, Next: Running Git, Prev: Completion Confirmation and the Selection, Up: Interface Concepts + +4.6 Mouse Support +================= + +Double clicking on a section heading toggles the visibility of its body, +if any. Likewise clicking in the left fringe toggles the visibility of +the appropriate section. + + A context menu is provided but has to be enabled explicitly. In +Emacs 28 and greater, enable the global mode ‘context-menu-mode’. If +you use an older Emacs release, set +‘magit-section-show-context-menu-for-emacs<28’. + + +File: doc5khxAZ.info, Node: Running Git, Prev: Mouse Support, Up: Interface Concepts + +4.7 Running Git +=============== + +* Menu: + +* Viewing Git Output:: +* Git Process Status:: +* Running Git Manually:: +* Git Executable:: +* Global Git Arguments:: + + +File: doc5khxAZ.info, Node: Viewing Git Output, Next: Git Process Status, Up: Running Git + +4.7.1 Viewing Git Output +------------------------ + +Magit runs Git either for side-effects (e.g., when pushing) or to get +some value (e.g., the name of the current branch). + + When Git is run for side-effects, the process output is logged in a +per-repository log buffer, which can be consulted using the +‘magit-process-buffer’ command, when things don’t go as expected. + + The output/errors for up to ‘magit-process-log-max’ Git commands are +retained. + +Key: $ (magit-process-buffer) + This commands displays the process buffer for the current + repository. + + Inside that buffer, the usual key bindings for navigating and showing +sections are available. There is one additional command. + +Key: k (magit-process-kill) + This command kills the process represented by the section at point. + +Key: M-x magit-toggle-git-debug + This command toggles whether additional git errors are reported. + + Magit basically calls git for one of these two reasons: for + side-effects or to do something with its standard output. + + When git is run for side-effects then its output, including error + messages, go into the process buffer which is shown when using ‘$’. + + When git’s output is consumed in some way, then it would be too + expensive to also insert it into this buffer, but with this command + that can be enabled temporarily. In that case, if git returns with + a non-zero exit status, then at least its standard error is + inserted into this buffer. + + Also note that just because git exits with a non-zero status and + prints an error message, that usually doesn’t mean that it is an + error as far as Magit is concerned, which is another reason we + usually hide these error messages. Whether some error message is + relevant in the context of some unexpected behavior has to be + judged on a case by case basis. + + +File: doc5khxAZ.info, Node: Git Process Status, Next: Running Git Manually, Prev: Viewing Git Output, Up: Running Git + +4.7.2 Git Process Status +------------------------ + +When a Git process is running for side-effects, Magit displays an +indicator in the mode line, using the ‘magit-mode-line-process’ face. + + If the Git process exits successfully, the process indicator is +removed from the mode line immediately. + + In the case of a Git error, the process indicator is not removed, but +is instead highlighted with the ‘magit-mode-line-process-error’ face, +and the error details from the process buffer are provided as a tooltip +for mouse users. This error indicator persists in the mode line until +the next magit buffer refresh. + + If you do not wish process errors to be indicated in the mode line, +set ‘magit-process-display-mode-line-error’ to ‘nil’. + + Process errors are displayed at the top of the status buffer and in +the echo area. In both places a hint is appended, which informs users +that they can see the full output in the process buffer and how to +display that buffer. However, once you are aware of that, you might +want to set ‘magit-show-process-buffer-hint’ to ‘nil’. + + +File: doc5khxAZ.info, Node: Running Git Manually, Next: Git Executable, Prev: Git Process Status, Up: Running Git + +4.7.3 Running Git Manually +-------------------------- + +While Magit provides many Emacs commands to interact with Git, it does +not cover everything. In those cases your existing Git knowledge will +come in handy. Magit provides some commands for running arbitrary Git +commands by typing them into the minibuffer, instead of having to switch +to a shell. + +Key: ! (magit-run) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: ! ! (magit-git-command-topdir) + This command reads a command from the user and executes it in the + top-level directory of the current working tree. + + The string "git " is used as initial input when prompting the user + for the command. It can be removed to run another command. + +Key: : (magit-git-command) + +Key: ! p + This command reads a command from the user and executes it in + ‘default-directory’. With a prefix argument the command is + executed in the top-level directory of the current working tree + instead. + + The string "git " is used as initial input when prompting the user + for the command. It can be removed to run another command. + +Key: ! s (magit-shell-command-topdir) + This command reads a command from the user and executes it in the + top-level directory of the current working tree. + +Key: ! S (magit-shell-command) + This command reads a command from the user and executes it in + ‘default-directory’. With a prefix argument the command is + executed in the top-level directory of the current working tree + instead. + +User Option: magit-shell-command-verbose-prompt + Whether the prompt, used by the above commands when reading a shell + command, shows the directory in which it will be run. + + These suffix commands start external gui tools. + +Key: ! k (magit-run-gitk) + This command runs ‘gitk’ in the current repository. + +Key: ! a (magit-run-gitk-all) + This command runs ‘gitk --all’ in the current repository. + +Key: ! b (magit-run-gitk-branches) + This command runs ‘gitk --branches’ in the current repository. + +Key: ! g (magit-run-git-gui) + This command runs ‘git gui’ in the current repository. + +Key: ! m (magit-git-mergetool) + This command runs ‘git mergetool --gui’ in the current repository. + + With a prefix argument this acts as a transient prefix command, + allowing the user to select the mergetool and change some settings. + + +File: doc5khxAZ.info, Node: Git Executable, Next: Global Git Arguments, Prev: Running Git Manually, Up: Running Git + +4.7.4 Git Executable +-------------------- + +When Magit calls Git, then it may do so using the absolute path to the +‘git’ executable, or using just its name. + + When running ‘git’ locally and the ‘system-type’ is ‘windows-nt’ (any +Windows version) or ‘darwin’ (macOS) then ‘magit-git-executable’ is set +to an absolute path when Magit is loaded. + + On Windows it is necessary to use an absolute path because Git comes +with several wrapper scripts for the actual ‘git’ binary, which are also +placed on ‘$PATH’, and using one of these wrappers instead of the binary +would degrade performance horribly. For some macOS users using just the +name of the executable also performs horribly, so we avoid doing that on +that platform as well. On other platforms, using just the name seems to +work just fine. + + Using an absolute path when running ‘git’ on a remote machine over +Tramp, would be problematic to use an absolute path that is suitable on +the local machine, so a separate option is used to control the name or +path that is used on remote machines. + +User Option: magit-git-executable + The ‘git’ executable used by Magit on the local host. This should + be either the absolute path to the executable, or the string "git" + to let Emacs find the executable itself, using the standard + mechanism for doing such things. + +User Option: magit-remote-git-executable + The ‘git’ executable used by Magit on remote machines over Tramp. + Normally this should be just the string "git". Consider + customizing ‘tramp-remote-path’ instead of this option. + + If Emacs is unable to find the correct executable, then you can work +around that by explicitly setting the value of one of these two options. +Doing that should be considered a kludge; it is better to make sure that +the order in ‘exec-path’ or ‘tramp-remote-path’ is correct. + + Note that ‘exec-path’ is set based on the value of the ‘PATH’ +environment variable that is in effect when Emacs is started. If you +set ‘PATH’ in your shell’s init files, then that only has an effect on +Emacs if you start it from that shell (because the environment of a +process is only passed to its child processes, not to arbitrary other +processes). If that is not how you start Emacs, then the +‘exec-path-from-shell’ package can help; though honestly I consider that +a kludge too. + + The command ‘magit-debug-git-executable’ can be useful to find out +where Emacs is searching for ‘git’. + +Key: M-x magit-debug-git-executable + This command displays a buffer with information about + ‘magit-git-executable’ and ‘magit-remote-git-executable’. + +Key: M-x magit-version + This command shows the currently used versions of Magit, Git, and + Emacs in the echo area. Non-interactively this just returns the + Magit version. + + +File: doc5khxAZ.info, Node: Global Git Arguments, Prev: Git Executable, Up: Running Git + +4.7.5 Global Git Arguments +-------------------------- + +User Option: magit-git-global-arguments + The arguments set here are used every time the git executable is + run as a subprocess. They are placed right after the executable + itself and before the git command - as in ‘git HERE... COMMAND + REST’. For valid arguments see [BROKEN LINK: man:git] + + Be careful what you add here, especially if you are using Tramp to + connect to servers with ancient Git versions. Never remove + anything that is part of the default value, unless you really know + what you are doing. And think very hard before adding something; + it will be used every time Magit runs Git for any purpose. + + +File: doc5khxAZ.info, Node: Inspecting, Next: Manipulating, Prev: Interface Concepts, Up: Top + +5 Inspecting +************ + +The functionality provided by Magit can be roughly divided into three +groups: inspecting existing data, manipulating existing data or adding +new data, and transferring data. Of course that is a rather crude +distinction that often falls short, but it’s more useful than no +distinction at all. This section is concerned with inspecting data, the +next two with manipulating and transferring it. Then follows a section +about miscellaneous functionality, which cannot easily be fit into this +distinction. + + Of course other distinctions make sense too, e.g., Git’s distinction +between porcelain and plumbing commands, which for the most part is +equivalent to Emacs’ distinction between interactive commands and +non-interactive functions. All of the sections mentioned before are +mainly concerned with the porcelain – Magit’s plumbing layer is +described later. + +* Menu: + +* Status Buffer:: +* Repository List:: +* Logging:: +* Diffing:: +* Ediffing:: +* References Buffer:: +* Bisecting:: +* Visiting Files and Blobs:: +* Blaming:: + + +File: doc5khxAZ.info, Node: Status Buffer, Next: Repository List, Up: Inspecting + +5.1 Status Buffer +================= + +While other Magit buffers contain, e.g., one particular diff or one +particular log, the status buffer contains the diffs for staged and +unstaged changes, logs for unpushed and unpulled commits, lists of +stashes and untracked files, and information related to the current +branch. + + During certain incomplete operations – for example when a merge +resulted in a conflict – additional information is displayed that helps +proceeding with or aborting the operation. + + The command ‘magit-status’ displays the status buffer belonging to +the current repository in another window. This command is used so often +that it should be bound globally. We recommend using ‘C-x g’: + + (global-set-key (kbd "C-x g") 'magit-status) + +Key: C-x g (magit-status) + When invoked from within an existing Git repository, then this + command shows the status of that repository in a buffer. + + If the current directory isn’t located within a Git repository, + then this command prompts for an existing repository or an + arbitrary directory, depending on the option + ‘magit-repository-directories’, and the status for the selected + repository is shown instead. + + • If that option specifies any existing repositories, then the + user is asked to select one of them. + + • Otherwise the user is asked to select an arbitrary directory + using regular file-name completion. If the selected directory + is the top-level directory of an existing working tree, then + the status buffer for that is shown. + + • Otherwise the user is offered to initialize the selected + directory as a new repository. After creating the repository + its status buffer is shown. + + These fallback behaviors can also be forced using one or more + prefix arguments: + + • With two prefix arguments (or more precisely a numeric prefix + value of 16 or greater) an arbitrary directory is read, which + is then acted on as described above. The same could be + accomplished using the command ‘magit-init’. + + • With a single prefix argument an existing repository is read + from the user, or if no repository can be found based on the + value of ‘magit-repository-directories’, then the behavior is + the same as with two prefix arguments. + +User Option: magit-repository-directories + List of directories that are Git repositories or contain Git + repositories. + + Each element has the form ‘(DIRECTORY . DEPTH)’. DIRECTORY has to + be a directory or a directory file-name, a string. DEPTH, an + integer, specifies the maximum depth to look for Git repositories. + If it is 0, then only add DIRECTORY itself. + + This option controls which repositories are being listed by + ‘magit-list-repositories’. It also affects ‘magit-status’ (which + see) in potentially surprising ways (see above). + +Command: magit-status-quick + This command is an alternative to ‘magit-status’ that usually + avoids refreshing the status buffer. + + If the status buffer of the current Git repository exists but isn’t + being displayed in the selected frame, then it is displayed without + being refreshed. + + If the status buffer is being displayed in the selected frame, then + this command refreshes it. + + Prefix arguments have the same meaning as for ‘magit-status’, and + additionally cause the buffer to be refresh. + + To use this command add this to your init file: + + (global-set-key (kbd "C-x g") 'magit-status-quick). + + If you do that and then for once want to redisplay the buffer and + also immediately refresh it, then type ‘C-x g’ followed by ‘g’. + + A possible alternative command is + ‘magit-display-repository-buffer’. It supports displaying any + existing Magit buffer that belongs to the current repository; not + just the status buffer. + +Command: ido-enter-magit-status + From an Ido prompt used to open a file, instead drop into + ‘magit-status’. This is similar to ‘ido-magic-delete-char’, which, + despite its name, usually causes a Dired buffer to be created. + + To make this command available, use something like: + + (add-hook 'ido-setup-hook + (lambda () + (define-key ido-completion-map + (kbd \"C-x g\") 'ido-enter-magit-status))) + + Starting with Emacs 25.1 the Ido keymaps are defined just once + instead of every time Ido is invoked, so now you can modify it like + pretty much every other keymap: + + (define-key ido-common-completion-map + (kbd \"C-x g\") 'ido-enter-magit-status) + +* Menu: + +* Status Sections:: +* Status File List Sections:: +* Status Log Sections:: +* Status Header Sections:: +* Status Module Sections:: +* Status Options:: + + +File: doc5khxAZ.info, Node: Status Sections, Next: Status File List Sections, Up: Status Buffer + +5.1.1 Status Sections +--------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’. See *note Section Hooks:: to learn about +such hooks and how to customize them. + +User Option: magit-status-sections-hook + This hook is run to insert sections into a status buffer. + + The functions described in this section, and the functions + ‘magit-insert-status-headers’ and ‘magit-insert-untracked-files’, + which are described in subsequent sections, are members of this + hook. + + Some additional functions that can be added to this hook, but are + by default added to another hooks, are listed in *note References + Buffer::. + +Function: magit-insert-merge-log + Insert section for the on-going merge. Display the heads that are + being merged. If no merge is in progress, do nothing. + +Function: magit-insert-rebase-sequence + Insert section for the on-going rebase sequence. If no such + sequence is in progress, do nothing. + +Function: magit-insert-am-sequence + Insert section for the on-going patch applying sequence. If no + such sequence is in progress, do nothing. + +Function: magit-insert-sequencer-sequence + Insert section for the on-going cherry-pick or revert sequence. If + no such sequence is in progress, do nothing. + +Function: magit-insert-bisect-output + While bisecting, insert section with output from ‘git bisect’. + +Function: magit-insert-bisect-rest + While bisecting, insert section visualizing the bisect state. + +Function: magit-insert-bisect-log + While bisecting, insert section logging bisect progress. + +Function: magit-insert-unstaged-changes + Insert section showing unstaged changes. + +Function: magit-insert-staged-changes + Insert section showing staged changes. + +Function: magit-insert-stashes &optional ref heading + Insert the ‘stashes’ section showing reflog for "refs/stash". If + optional REF is non-nil show reflog for that instead. If optional + HEADING is non-nil use that as section heading instead of + "Stashes:". + +Function: magit-insert-unpulled-from-upstream + Insert section showing commits that haven’t been pulled from the + upstream branch yet. + +Function: magit-insert-unpulled-from-pushremote + Insert section showing commits that haven’t been pulled from the + push-remote branch yet. + +Function: magit-insert-unpushed-to-upstream + Insert section showing commits that haven’t been pushed to the + upstream yet. + +Function: magit-insert-unpushed-to-pushremote + Insert section showing commits that haven’t been pushed to the + push-remote yet. + + +File: doc5khxAZ.info, Node: Status File List Sections, Next: Status Log Sections, Prev: Status Sections, Up: Status Buffer + +5.1.2 Status File List Sections +------------------------------- + +These functions honor the buffer’s file filter, which can be set using +‘D - -’. + +Function: magit-insert-untracked-files + This function may insert a list of untracked files. Whether it + actually does so, depends on the option described next. + +User Option: magit-status-show-untracked-files + This option controls whether the above function inserts a list of + untracked files in the status buffer. + + • If ‘nil’, do not list any untracked files. + • If ‘t’, list untracked files, but if a directory does not + contain any untracked files, then only list that directory, + not the contained untracked files. + • If ‘all’, then list each individual untracked files. This is + can be very slow and is discouraged. + + The corresponding values for the Git variable are "no", "normal" + and "all". + + To disable listing untracked files in a specific repository only, + add the following to ‘.dir-locals.el’: + + ((magit-status-mode + (magit-status-show-untracked-files . "no"))) + + Alternatively (and mostly for historic reasons), it is possible to + use ‘git config’ to set the repository-local value: + + git config set --local status.showUntrackedFiles no + + This does *not* override the (if any) local value of this Lisp + variable, but it does override its global value. + + See the last section in the git-status(1) manpage, to speed up the + part of the work Git is responsible for. Turning that list into + sections is also not free, so Magit only lists + ‘magit-status-file-list-limit’ files. + +User Option: magit-status-file-list-limit + This option controls many files are listed at most in each section + that lists files in the status buffer. For performance reasons, it + is recommended that you do not increase this limit. + + While the above function is a member of ‘magit-status-section-hook’ +by default, the following functions have to be explicitly added by the +user. Because that negatively affects performance, it is recommended +that you don’t do that. + +Function: magit-insert-tracked-files + Insert a list of tracked files. + +Function: magit-insert-ignored-files + Insert a list of ignored files. + +Function: magit-insert-skip-worktree-files + Insert a list of skip-worktree files. + +Function: magit-insert-assumed-unchanged-files + Insert a list of files that are assumed to be unchanged. + + +File: doc5khxAZ.info, Node: Status Log Sections, Next: Status Header Sections, Prev: Status File List Sections, Up: Status Buffer + +5.1.3 Status Log Sections +------------------------- + +Function: magit-insert-unpulled-or-recent-commits + Insert section showing unpulled or recent commits. If an upstream + is configured for the current branch and it is ahead of the current + branch, then show the missing commits. Otherwise, show the last + ‘magit-log-section-commit-count’ commits. + +Function: magit-insert-recent-commits + Insert section showing the last ‘magit-log-section-commit-count’ + commits. + +User Option: magit-log-section-commit-count + How many recent commits ‘magit-insert-recent-commits’ and + ‘magit-insert-unpulled-or-recent-commits’ (provided there are no + unpulled commits) show. + +Function: magit-insert-unpulled-cherries + Insert section showing unpulled commits. Like + ‘magit-insert-unpulled-commits’ but prefix each commit that has not + been applied yet (i.e., a commit with a patch-id not shared with + any local commit) with "+", and all others with "-". + +Function: magit-insert-unpushed-cherries + Insert section showing unpushed commits. Like + ‘magit-insert-unpushed-commits’ but prefix each commit which has + not been applied to upstream yet (i.e., a commit with a patch-id + not shared with any upstream commit) with "+" and all others with + "-". + + +File: doc5khxAZ.info, Node: Status Header Sections, Next: Status Module Sections, Prev: Status Log Sections, Up: Status Buffer + +5.1.4 Status Header Sections +---------------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’ (see *note Status Sections::). + + By default ‘magit-insert-status-headers’ is the first member of that +hook variable. + +Function: magit-insert-status-headers + Insert headers sections appropriate for ‘magit-status-mode’ + buffers. The sections are inserted by running the functions on the + hook ‘magit-status-headers-hook’. + +User Option: magit-status-headers-hook + Hook run to insert headers sections into the status buffer. + + This hook is run by ‘magit-insert-status-headers’, which in turn + has to be a member of ‘magit-status-sections-hook’ to be used at + all. + + By default the following functions are members of the above hook: + +Function: magit-insert-error-header + Insert a header line showing the message about the Git error that + just occurred. + + This function is only aware of the last error that occur when Git + was run for side-effects. If, for example, an error occurs while + generating a diff, then that error won’t be inserted. Refreshing + the status buffer causes this section to disappear again. + +Function: magit-insert-diff-filter-header + Insert a header line showing the effective diff filters. + +Function: magit-insert-head-branch-header + Insert a header line about the current branch or detached ‘HEAD’. + +Function: magit-insert-upstream-branch-header + Insert a header line about the branch that is usually pulled into + the current branch. + +Function: magit-insert-push-branch-header + Insert a header line about the branch that the current branch is + usually pushed to. + +Function: magit-insert-tags-header + Insert a header line about the current and/or next tag, along with + the number of commits between the tag and ‘HEAD’. + + The following functions can also be added to the above hook: + +Function: magit-insert-repo-header + Insert a header line showing the path to the repository top-level. + +Function: magit-insert-remote-header + Insert a header line about the remote of the current branch. + + If no remote is configured for the current branch, then fall back + showing the "origin" remote, or if that does not exist the first + remote in alphabetic order. + +Function: magit-insert-user-header + Insert a header line about the current user. + + +File: doc5khxAZ.info, Node: Status Module Sections, Next: Status Options, Prev: Status Header Sections, Up: Status Buffer + +5.1.5 Status Module Sections +---------------------------- + +The contents of status buffers is controlled using the hook +‘magit-status-sections-hook’ (see *note Status Sections::). + + By default ‘magit-insert-modules’ is _not_ a member of that hook +variable. + +Function: magit-insert-modules + Insert submodule sections. + + Hook ‘magit-module-sections-hook’ controls which module sections + are inserted, and option ‘magit-module-sections-nested’ controls + whether they are wrapped in an additional section. + +User Option: magit-module-sections-hook + Hook run by ‘magit-insert-modules’. + +User Option: magit-module-sections-nested + This option controls whether ‘magit-insert-modules’ wraps inserted + sections in an additional section. + + If this is non-nil, then only a single top-level section is + inserted. If it is nil, then all sections listed in + ‘magit-module-sections-hook’ become top-level sections. + +Function: magit-insert-modules-overview + Insert sections for all submodules. For each section insert the + path, the branch, and the output of ‘git describe --tags’, or, + failing that, the abbreviated HEAD commit hash. + + Press ‘RET’ on such a submodule section to show its own status + buffer. Press ‘RET’ on the "Modules" section to display a list of + submodules in a separate buffer. This shows additional information + not displayed in the super-repository’s status buffer. + +Function: magit-insert-modules-unpulled-from-upstream + Insert sections for modules that haven’t been pulled from the + upstream yet. These sections can be expanded to show the + respective commits. + +Function: magit-insert-modules-unpulled-from-pushremote + Insert sections for modules that haven’t been pulled from the + push-remote yet. These sections can be expanded to show the + respective commits. + +Function: magit-insert-modules-unpushed-to-upstream + Insert sections for modules that haven’t been pushed to the + upstream yet. These sections can be expanded to show the + respective commits. + +Function: magit-insert-modules-unpushed-to-pushremote + Insert sections for modules that haven’t been pushed to the + push-remote yet. These sections can be expanded to show the + respective commits. + + +File: doc5khxAZ.info, Node: Status Options, Prev: Status Module Sections, Up: Status Buffer + +5.1.6 Status Options +-------------------- + +User Option: magit-status-margin + This option specifies whether the margin is initially shown in + Magit-Status mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + Also see the proceeding section for more options concerning status +buffers. + + +File: doc5khxAZ.info, Node: Repository List, Next: Logging, Prev: Status Buffer, Up: Inspecting + +5.2 Repository List +=================== + +Command: magit-list-repositories + This command displays a list of repositories in a separate buffer. + + The option ‘magit-repository-directories’ controls which + repositories are displayed. + +User Option: magit-repolist-columns + This option controls what columns are displayed by the command + ‘magit-list-repositories’ and how they are displayed. + + Each element has the form ‘(HEADER WIDTH FORMAT PROPS)’. + + HEADER is the string displayed in the header. WIDTH is the width + of the column. FORMAT is a function that is called with one + argument, the repository identification (usually its basename), and + with ‘default-directory’ bound to the toplevel of its working tree. + It has to return a string to be inserted or nil. PROPS is an alist + that supports the keys ‘:right-align’, ‘:pad-right’ and ‘:sort’. + + The ‘:sort’ function has a weird interface described in the + docstring of ‘tabulated-list--get-sort’. Alternatively ‘<’ and + ‘magit-repolist-version<’ can be used as those functions are + automatically replaced with functions that satisfy the interface. + Set ‘:sort’ to ‘nil’ to inhibit sorting; if unspecified, then the + column is sortable using the default sorter. + + You may wish to display a range of numeric columns using just one + character per column and without any padding between columns, in + which case you should use an appropriate HEADER, set WIDTH to 1, + and set ‘:pad-right’ to 9. ‘+’ is substituted for numbers higher + than 9. + +The following functions can be added to the above option: + +Function: magit-repolist-column-ident + This function inserts the identification of the repository. + Usually this is just its basename. + +Function: magit-repolist-column-path + This function inserts the absolute path of the repository. + +Function: magit-repolist-column-version + This function inserts a description of the repository’s ‘HEAD’ + revision. + +Function: magit-repolist-column-branch + This function inserts the name of the current branch. + +Function: magit-repolist-column-upstream + This function inserts the name of the upstream branch of the + current branch. + +Function: magit-repolist-column-branches + This function inserts the number of branches. + +Function: magit-repolist-column-stashes + This function inserts the number of stashes. + +Function: magit-repolist-column-flag + This function inserts a flag as specified by + ‘magit-repolist-column-flag-alist’. + + By default this indicates whether there are uncommitted changes. + + • ‘N’ if there is at least one untracked file. + • ‘U’ if there is at least one unstaged file. + • ‘S’ if there is at least one staged file. + + Only the first one of these that applies is shown. + +Function: magit-repolist-column-flags + This functions insert all flags as specified by + ‘magit-repolist-column-flag-alist’. + + This is an alternative to function ‘magit-repolist-column-flag’, + which only lists the first one found. + +Function: magit-repolist-column-unpulled-from-upstream + This function inserts the number of upstream commits not in the + current branch. + +Function: magit-repolist-column-unpulled-from-pushremote + This function inserts the number of commits in the push branch but + not the current branch. + +Function: magit-repolist-column-unpushed-to-upstream + This function inserts the number of commits in the current branch + but not its upstream. + +Function: magit-repolist-column-unpushed-to-pushremote + This function inserts the number of commits in the current branch + but not its push branch. + +The following commands are available in repolist buffers: + +Key: RET (magit-repolist-status) + This command shows the status for the repository at point. + +Key: m (magit-repolist-mark) + This command marks the repository at point. + +Key: u (magit-repolist-unmark) + This command unmarks the repository at point. + +Key: f (magit-repolist-fetch) + This command fetches all marked repositories. If no repositories + are marked, then it offers to fetch all displayed repositories. + +Key: 5 (magit-repolist-find-file-other-frame) + This command reads a relative file-name (without completion) and + opens the respective file in each marked repository in a new frame. + If no repositories are marked, then it offers to do this for all + displayed repositories. + + +File: doc5khxAZ.info, Node: Logging, Next: Diffing, Prev: Repository List, Up: Inspecting + +5.3 Logging +=========== + +The status buffer contains logs for the unpushed and unpulled commits, +but that obviously isn’t enough. The transient prefix command +‘magit-log’, on ‘l’, features several suffix commands, which show a +specific log in a separate log buffer. + + Like other transient prefix commands, ‘magit-log’ also features +several infix arguments that can be changed before invoking one of the +suffix commands. However, in the case of the log transient, these +arguments may be taken from those currently in use in the current +repository’s log buffer, depending on the value of +‘magit-prefix-use-buffer-arguments’ (see *note Transient Arguments and +Buffer Variables::). + + For information about the various arguments, see [BROKEN LINK: +man:git-log] The switch ‘++order=VALUE’ is converted to one of +‘--author-date-order’, ‘--date-order’, or ‘--topo-order’ before being +passed to ‘git log’. + + The log transient also features several reflog commands. See *note +Reflog::. + +Key: l (magit-log) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: l l (magit-log-current) + Show log for the current branch. When ‘HEAD’ is detached or with a + prefix argument, show log for one or more revs read from the + minibuffer. + +Key: l h (magit-log-head) + Show log for ‘HEAD’. + +Key: l u (magit-log-related) + Show log for the current branch, its upstream and its push target. + When the upstream is a local branch, then also show its own + upstream. When ‘HEAD’ is detached, then show log for that, the + previously checked out branch and its upstream and push-target. + +Key: l o (magit-log-other) + Show log for one or more revs read from the minibuffer. The user + can input any revision or revisions separated by a space, or even + ranges, but only branches, tags, and a representation of the commit + at point are available as completion candidates. + +Key: l L (magit-log-branches) + Show log for all local branches and ‘HEAD’. + +Key: l b (magit-log-all-branches) + Show log for all local and remote branches and ‘HEAD’. + +Key: l a (magit-log-all) + Show log for all references and ‘HEAD’. + + Two additional commands that show the log for the file or blob that +is being visited in the current buffer exists, see *note Commands for +Buffers Visiting Files::. The command ‘magit-cherry’ also shows a log, +see *note Cherries::. + +* Menu: + +* Refreshing Logs:: +* Log Buffer:: +* Log Margin:: +* Select from Log:: +* Reflog:: +* Cherries:: + + +File: doc5khxAZ.info, Node: Refreshing Logs, Next: Log Buffer, Up: Logging + +5.3.1 Refreshing Logs +--------------------- + +The transient prefix command ‘magit-log-refresh’, on ‘L’, can be used to +change the log arguments used in the current buffer, without changing +which log is shown. This works in dedicated log buffers, but also in +the status buffer. + +Key: L (magit-log-refresh) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: L g (magit-log-refresh) + This suffix command sets the local log arguments for the current + buffer. + +Key: L s (magit-log-set-default-arguments) + This suffix command sets the default log arguments for buffers of + the same type as that of the current buffer. Other existing + buffers of the same type are not affected because their local + values have already been initialized. + +Key: L w (magit-log-save-default-arguments) + This suffix command sets the default log arguments for buffers of + the same type as that of the current buffer, and saves the value + for future sessions. Other existing buffers of the same type are + not affected because their local values have already been + initialized. + +Key: L L (magit-toggle-margin) + Show or hide the margin. + + +File: doc5khxAZ.info, Node: Log Buffer, Next: Log Margin, Prev: Refreshing Logs, Up: Logging + +5.3.2 Log Buffer +---------------- + +Key: L (magit-log-refresh) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + See *note Refreshing Logs::. + +Key: q (magit-log-bury-buffer) + Bury the current buffer or the revision buffer in the same frame. + Like ‘magit-mode-bury-buffer’ (which see) but with a negative + prefix argument instead bury the revision buffer, provided it is + displayed in the current frame. + +Key: C-c C-b (magit-go-backward) + Move backward in current buffer’s history. + +Key: C-c C-f (magit-go-forward) + Move forward in current buffer’s history. + +Key: C-c C-n (magit-log-move-to-parent) + Move to a parent of the current commit. By default, this is the + first parent, but a numeric prefix can be used to specify another + parent. + +Key: j (magit-log-move-to-revision) + Read a revision and move to it in current log buffer. + + If the chosen reference or revision isn’t being displayed in the + current log buffer, then inform the user about that and do nothing + else. + + If invoked outside any log buffer, then display the log buffer of + the current repository first; creating it if necessary. + +Key: SPC (magit-diff-show-or-scroll-up) + Update the commit or diff buffer for the thing at point. + + Either show the commit or stash at point in the appropriate buffer, + or if that buffer is already being displayed in the current frame + and contains information about that commit or stash, then instead + scroll the buffer up. If there is no commit or stash at point, + then prompt for a commit. + +Key: DEL (magit-diff-show-or-scroll-down) + Update the commit or diff buffer for the thing at point. + + Either show the commit or stash at point in the appropriate buffer, + or if that buffer is already being displayed in the current frame + and contains information about that commit or stash, then instead + scroll the buffer down. If there is no commit or stash at point, + then prompt for a commit. + +Key: = (magit-log-toggle-commit-limit) + Toggle the number of commits the current log buffer is limited to. + If the number of commits is currently limited, then remove that + limit. Otherwise set it to 256. + +Key: + (magit-log-double-commit-limit) + Double the number of commits the current log buffer is limited to. + +Key: - (magit-log-half-commit-limit) + Half the number of commits the current log buffer is limited to. + +User Option: magit-log-auto-more + Insert more log entries automatically when moving past the last + entry. Only considered when moving past the last entry with + ‘magit-goto-*-section’ commands. + +User Option: magit-log-show-refname-after-summary + Whether to show the refnames after the commit summaries. This is + useful if you use really long branch names. + +User Option: magit-log-show-color-graph-limit + When showing more commits than specified by this option, then the + ‘--color’ argument, if specified, is silently dropped. This is + necessary because the ‘ansi-color’ library, which is used to turn + control sequences into faces, is just too slow. + +User Option: magit-log-show-signatures-limit + When showing more commits than specified by this option, then the + ‘--show-signature’ argument, if specified, is silently dropped. + This is necessary because checking the signature of a large number + of commits is just too slow. + + Magit displays references in logs a bit differently from how Git does +it. + + Local branches are blue and remote branches are green. Of course +that depends on the used theme, as do the colors used for other types of +references. The current branch has a box around it, as do remote +branches that are their respective remote’s ‘HEAD’ branch. + + If a local branch and its push-target point at the same commit, then +their names are combined to preserve space and to make that relationship +visible. For example: + + origin/feature + [green][blue-] + + instead of + + feature origin/feature + [blue-] [green-------] + + Also note that while the transient features the ‘--show-signature’ +argument, that won’t actually be used when enabled, because Magit +defaults to use just one line per commit. Instead the commit colorized +to indicate the validity of the signed commit object, using the faces +named ‘magit-signature-*’ (which see). + + For a description of ‘magit-log-margin’ see *note Log Margin::. + + +File: doc5khxAZ.info, Node: Log Margin, Next: Select from Log, Prev: Log Buffer, Up: Logging + +5.3.3 Log Margin +---------------- + +In buffers which show one or more logs, it is possible to show +additional information about each commit in the margin. The options +used to configure the margin are named ‘magit-INFIX-margin’, where INFIX +is the same as in the respective major-mode ‘magit-INFIX-mode’. In +regular log buffers that would be ‘magit-log-margin’. + +User Option: magit-log-margin + This option specifies whether the margin is initially shown in + Magit-Log mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + You can change the STYLE and AUTHOR-WIDTH of all ‘magit-INFIX-margin’ +options to the same values by customizing ‘magit-log-margin’ *before* +‘magit’ is loaded. If you do that, then the respective values for the +other options will default to what you have set for that variable. +Likewise if you set INIT in ‘magit-log-margin’ to ‘nil’, then that is +used in the default of all other options. But setting it to ‘t’, i.e. +re-enforcing the default for that option, does not carry to other +options. + +User Option: magit-log-margin-show-committer-date + This option specifies whether to show the committer date in the + margin. This option only controls whether the committer date is + displayed instead of the author date. Whether some date is + displayed in the margin and whether the margin is displayed at all + is controlled by other options. + +Key: L (magit-margin-settings) + This transient prefix command binds the following suffix commands, + each of which changes the appearance of the margin in some way. + + In some buffers that support the margin, ‘L’ is instead bound to +‘magit-log-refresh’, but that transient features the same commands, and +then some other unrelated commands. + +Key: L L (magit-toggle-margin) + This command shows or hides the margin. + +Key: L l (magit-cycle-margin-style) + This command cycles the style used for the margin. + +Key: L d (magit-toggle-margin-details) + This command shows or hides details in the margin. + + +File: doc5khxAZ.info, Node: Select from Log, Next: Reflog, Prev: Log Margin, Up: Logging + +5.3.4 Select from Log +--------------------- + +When the user has to select a recent commit that is reachable from +‘HEAD’, using regular completion would be inconvenient (because most +humans cannot remember hashes or "HEAD~5", at least not without double +checking). Instead a log buffer is used to select the commit, which has +the advantage that commits are presented in order and with the commit +message. + + Such selection logs are used when selecting the beginning of a rebase +and when selecting the commit to be squashed into. + + In addition to the key bindings available in all log buffers, the +following additional key bindings are available in selection log +buffers: + +Key: C-c C-c (magit-log-select-pick) + Select the commit at point and act on it. Call + ‘magit-log-select-pick-function’ with the selected commit as + argument. + +Key: C-c C-k (magit-log-select-quit) + Abort selecting a commit, don’t act on any commit. + +User Option: magit-log-select-margin + This option specifies whether the margin is initially shown in + Magit-Log-Select mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: doc5khxAZ.info, Node: Reflog, Next: Cherries, Prev: Select from Log, Up: Logging + +5.3.5 Reflog +------------ + +Also see [BROKEN LINK: man:git-reflog] + + These reflog commands are available from the log transient. See +*note Logging::. + +Key: l r (magit-reflog-current) + Display the reflog of the current branch. + +Key: l O (magit-reflog-other) + Display the reflog of a branch or another ref. + +Key: l H (magit-reflog-head) + Display the ‘HEAD’ reflog. + +User Option: magit-reflog-margin + This option specifies whether the margin is initially shown in + Magit-Reflog mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: doc5khxAZ.info, Node: Cherries, Prev: Reflog, Up: Logging + +5.3.6 Cherries +-------------- + +Cherries are commits that haven’t been applied upstream (yet), and are +usually visualized using a log. Each commit is prefixed with ‘-’ if it +has an equivalent in the upstream and ‘+’ if it does not, i.e., if it is +a cherry. + + The command ‘magit-cherry’ shows cherries for a single branch, but +the references buffer (see *note References Buffer::) can show cherries +for multiple "upstreams" at once. + + Also see [BROKEN LINK: man:git-reflog] + +Key: Y (magit-cherry) + Show commits that are in a certain branch but that have not been + merged in the upstream branch. + +User Option: magit-cherry-margin + This option specifies whether the margin is initially shown in + Magit-Cherry mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: doc5khxAZ.info, Node: Diffing, Next: Ediffing, Prev: Logging, Up: Inspecting + +5.4 Diffing +=========== + +The status buffer contains diffs for the staged and unstaged commits, +but that obviously isn’t enough. The transient prefix command +‘magit-diff’, on ‘d’, features several suffix commands, which show a +specific diff in a separate diff buffer. + + Like other transient prefix commands, ‘magit-diff’ also features +several infix arguments that can be changed before invoking one of the +suffix commands. However, in the case of the diff transient, these +arguments may be taken from those currently in use in the current +repository’s diff buffer, depending on the value of +‘magit-prefix-use-buffer-arguments’ (see *note Transient Arguments and +Buffer Variables::). + + Also see [BROKEN LINK: man:git-diff] + +Key: d (magit-diff) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: d d (magit-diff-dwim) + Show changes for the thing at point. + + For example, if point is on a commit, show the changes introduced + by that commit. Likewise if point is on the section titled + "Unstaged changes", then show those changes in a separate buffer. + Generally speaking, compare the thing at point with the most + logical, trivial and (in *any* situation) at least potentially + useful other thing it could be compared to. + + When the region selects commits, then compare the two commits at + either end. There are different ways two commits can be compared. + In the buffer showing the diff, you can control how the comparison, + is done, using "D r" and "D f". + + This function does not always show the changes that you might want + to view in any given situation. You can think of the changes being + shown as the smallest common denominator. There is no AI involved. + If this command never does what you want, then ignore it, and + instead use the commands that allow you to explicitly specify what + you need. + +Key: d r (magit-diff-range) + Show differences between two commits. + + RANGE should be a range (A..B or A...B) but can also be a single + commit. If one side of the range is omitted, then it defaults to + ‘HEAD’. If just a commit is given, then changes in the working + tree relative to that commit are shown. + + If the region is active, use the revisions on the first and last + line of the region. With a prefix argument, instead of diffing the + revisions, choose a revision to view changes along, starting at the + common ancestor of both revisions (i.e., use a "..." range). + +Key: d w (magit-diff-working-tree) + Show changes between the current working tree and the ‘HEAD’ + commit. With a prefix argument show changes between the working + tree and a commit read from the minibuffer. + +Key: d s (magit-diff-staged) + Show changes between the index and the ‘HEAD’ commit. With a + prefix argument show changes between the index and a commit read + from the minibuffer. + +Key: d u (magit-diff-unstaged) + Show changes between the working tree and the index. + +Key: d p (magit-diff-paths) + Show changes between any two files on disk. + + All of the above suffix commands update the repository’s diff buffer. +The diff transient also features two commands which show differences in +another buffer: + +Key: d c (magit-show-commit) + Show the commit at point. If there is no commit at point or with a + prefix argument, prompt for a commit. + +Key: d t (magit-stash-show) + Show all diffs of a stash in a buffer. + + Two additional commands that show the diff for the file or blob that +is being visited in the current buffer exists, see *note Commands for +Buffers Visiting Files::. + +* Menu: + +* Refreshing Diffs:: +* Commands Available in Diffs:: +* Diff Options:: +* Revision Buffer:: + + +File: doc5khxAZ.info, Node: Refreshing Diffs, Next: Commands Available in Diffs, Up: Diffing + +5.4.1 Refreshing Diffs +---------------------- + +The transient prefix command ‘magit-diff-refresh’, on ‘D’, can be used +to change the diff arguments used in the current buffer, without +changing which diff is shown. This works in dedicated diff buffers, but +also in the status buffer. + + (There is one exception; diff arguments cannot be changed in buffers +created by ‘magit-merge-preview’ because the underlying Git command does +not support these arguments.) + +Key: D (magit-diff-refresh) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: D g (magit-diff-refresh) + This suffix command sets the local diff arguments for the current + buffer. + +Key: D s (magit-diff-set-default-arguments) + This suffix command sets the default diff arguments for buffers of + the same type as that of the current buffer. Other existing + buffers of the same type are not affected because their local + values have already been initialized. + +Key: D w (magit-diff-save-default-arguments) + This suffix command sets the default diff arguments for buffers of + the same type as that of the current buffer, and saves the value + for future sessions. Other existing buffers of the same type are + not affected because their local values have already been + initialized. + +Key: D t (magit-diff-toggle-refine-hunk) + This command toggles hunk refinement on or off. + +Key: D r (magit-diff-switch-range-type) + This command converts the diff range type from "revA..revB" to + "revB...revA", or vice versa. + +Key: D f (magit-diff-flip-revs) + This command swaps revisions in the diff range from "revA..revB" to + "revB..revA", or vice versa. + +Key: D F (magit-diff-toggle-file-filter) + This command toggles the file restriction of the diffs in the + current buffer, allowing you to quickly switch between viewing all + the changes in the commit and the restricted subset. As a special + case, when this command is called from a log buffer, it toggles the + file restriction in the repository’s revision buffer, which is + useful when you display a revision from a log buffer that is + restricted to a file or files. + + In addition to the above transient, which allows changing any of the +supported arguments, there also exist some commands that change only a +particular argument. + +Key: - (magit-diff-less-context) + This command decreases the context for diff hunks by COUNT lines. + +Key: + (magit-diff-more-context) + This command increases the context for diff hunks by COUNT lines. + +Key: 0 (magit-diff-default-context) + This command resets the context for diff hunks to the default + height. + + The following commands quickly change what diff is being displayed +without having to using one of the diff transient. + +Key: C-c C-d (magit-diff-while-committing) + While committing, this command shows the changes that are about to + be committed. While amending, invoking the command again toggles + between showing just the new changes or all the changes that will + be committed. + + This binding is available in the diff buffer as well as the commit + message buffer. + +Key: C-c C-b (magit-go-backward) + This command moves backward in current buffer’s history. + +Key: C-c C-f (magit-go-forward) + This command moves forward in current buffer’s history. + + +File: doc5khxAZ.info, Node: Commands Available in Diffs, Next: Diff Options, Prev: Refreshing Diffs, Up: Diffing + +5.4.2 Commands Available in Diffs +--------------------------------- + +Some commands are only available if point is inside a diff. + + ‘magit-diff-visit-file’ and related commands visit the appropriate +version of the file that the diff at point is about. Likewise +‘magit-diff-visit-worktree-file’ and related commands visit the worktree +version of the file that the diff at point is about. See *note Visiting +Files and Blobs from a Diff:: for more information and the key bindings. + +Key: C-c C-t (magit-diff-trace-definition) + This command shows a log for the definition at point. + +User Option: magit-log-trace-definition-function + The function specified by this option is used by + ‘magit-log-trace-definition’ to determine the function at point. + For major-modes that have special needs, you could set the local + value using the mode’s hook. + +Key: C-c C-e (magit-diff-edit-hunk-commit) + From a hunk, this command edits the respective commit and visits + the file. + + First it visits the file being modified by the hunk at the correct + location using ‘magit-diff-visit-file’. This actually visits a + blob. When point is on a diff header, not within an individual + hunk, then this visits the blob the first hunk is about. + + Then it invokes ‘magit-edit-line-commit’, which uses an interactive + rebase to make the commit editable, or if that is not possible + because the commit is not reachable from ‘HEAD’ by checking out + that commit directly. This also causes the actual worktree file to + be visited. + + Neither the blob nor the file buffer are killed when finishing the + rebase. If that is undesirable, then it might be better to use + ‘magit-rebase-edit-commit’ instead of this command. + +Key: j (magit-jump-to-diffstat-or-diff) + This command jumps to the diffstat or diff. When point is on a + file inside the diffstat section, then jump to the respective diff + section. Otherwise, jump to the diffstat section or a child + thereof. + + The next two commands are not specific to Magit-Diff mode (or and +Magit buffer for that matter), but it might be worth pointing out that +they are available here too. + +Key: SPC (scroll-up) + This command scrolls text upward. + +Key: DEL (scroll-down) + This command scrolls text downward. + + +File: doc5khxAZ.info, Node: Diff Options, Next: Revision Buffer, Prev: Commands Available in Diffs, Up: Diffing + +5.4.3 Diff Options +------------------ + +User Option: magit-diff-refine-hunk + Whether to show word-granularity differences within diff hunks. + + • ‘nil’ Never show fine differences. + • ‘all’ Show fine differences for all displayed diff hunks. + • ‘t’ Refine each hunk once it becomes the current section. + Keep the refinement when another section is selected. + Refreshing the buffer removes all refinement. This variant is + only provided for performance reasons. + +User Option: magit-diff-refine-ignore-whitespace + Whether to ignore whitespace changes in word-granularity + differences. + +User Option: magit-diff-adjust-tab-width + Whether to adjust the width of tabs in diffs. + + Determining the correct width can be expensive if it requires + opening large and/or many files, so the widths are cached in the + variable ‘magit-diff--tab-width-cache’. Set that to nil to + invalidate the cache. + + • ‘nil’ Never adjust tab width. Use ‘tab-width’s value from the + Magit buffer itself instead. + + • ‘t’ If the corresponding file-visiting buffer exits, then use + ‘tab-width’’s value from that buffer. Doing this is cheap, so + this value is used even if a corresponding cache entry exists. + + • ‘always’ If there is no such buffer, then temporarily visit + the file to determine the value. + + • NUMBER Like ‘always’, but don’t visit files larger than NUMBER + bytes. + +User Option: magit-diff-paint-whitespace + Specify where to highlight whitespace errors. + + See ‘magit-diff-highlight-trailing’, + ‘magit-diff-highlight-indentation’. The symbol ‘t’ means in all + diffs, ‘status’ means only in the status buffer, and nil means + nowhere. + + • ‘nil’ Never highlight whitespace errors. + • ‘t’ Highlight whitespace errors everywhere. + • ‘uncommitted’ Only highlight whitespace errors in diffs + showing uncommitted changes. For backward compatibility + ‘status’ is treated as a synonym. + +User Option: magit-diff-paint-whitespace-lines + Specify in what kind of lines to highlight whitespace errors. + + • ‘t’ Highlight only in added lines. + • ‘both’ Highlight in added and removed lines. + • ‘all’ Highlight in added, removed and context lines. + +User Option: magit-diff-highlight-trailing + Whether to highlight whitespace at the end of a line in diffs. + Used only when ‘magit-diff-paint-whitespace’ is non-nil. + +User Option: magit-diff-highlight-indentation + This option controls whether to highlight the indentation in case + it used the "wrong" indentation style. Indentation is only + highlighted if ‘magit-diff-paint-whitespace’ is also non-nil. + + The value is an alist of the form ‘((REGEXP . INDENT)...)’. The + path to the current repository is matched against each element in + reverse order. Therefore if a REGEXP matches, then earlier + elements are not tried. + + If the used INDENT is ‘tabs’, highlight indentation with tabs. If + INDENT is an integer, highlight indentation with at least that many + spaces. Otherwise, highlight neither. + +User Option: magit-diff-hide-trailing-cr-characters + Whether to hide ^M characters at the end of a line in diffs. + +User Option: magit-diff-highlight-hunk-region-functions + This option specifies the functions used to highlight the + hunk-internal region. + + ‘magit-diff-highlight-hunk-region-dim-outside’ overlays the outside + of the hunk internal selection with a face that causes the added + and removed lines to have the same background color as context + lines. This function should not be removed from the value of this + option. + + ‘magit-diff-highlight-hunk-region-using-overlays’ and + ‘magit-diff-highlight-hunk-region-using-underline’ emphasize the + region by placing delimiting horizontal lines before and after it. + Both of these functions have glitches which cannot be fixed due to + limitations of Emacs’ display engine. For more information see + ff. + + Instead of, or in addition to, using delimiting horizontal lines, + to emphasize the boundaries, you may wish to emphasize the text + itself, using ‘magit-diff-highlight-hunk-region-using-face’. + + In terminal frames it’s not possible to draw lines as the overlay + and underline variants normally do, so there they fall back to + calling the face function instead. + +User Option: magit-diff-unmarked-lines-keep-foreground + This option controls whether added and removed lines outside the + hunk-internal region only lose their distinct background color or + also the foreground color. Whether the outside of the region is + dimmed at all depends on + ‘magit-diff-highlight-hunk-region-functions’. + +User Option: magit-diff-extra-stat-arguments + This option specifies additional arguments to be used alongside + ‘--stat’. + + The value is a list of zero or more arguments or a function that + takes no argument and returns such a list. These arguments are + allowed here: ‘--stat-width’, ‘--stat-name-width’, + ‘--stat-graph-width’ and ‘--compact-summary’. Also see [BROKEN + LINK: man:git-diff] + +User Option: magit-format-file-function + This function is used to format lines representing a file. It is + used for file headings in diffs, in diffstats and for lists of + files (such as the untracked files). Depending on the caller, it + receives either three or five arguments; the signature has to be + ‘(kind file face &optional status orig)’. KIND is one of ‘diff’, + ‘module’, ‘stat’ and ‘list’. + + +File: doc5khxAZ.info, Node: Revision Buffer, Prev: Diff Options, Up: Diffing + +5.4.4 Revision Buffer +--------------------- + +User Option: magit-revision-insert-related-refs + Whether to show related branches in revision buffers. + + • ‘nil’ Don’t show any related branches. + • ‘t’ Show related local branches. + • ‘all’ Show related local and remote branches. + • ‘mixed’ Show all containing branches and local merged + branches. + +User Option: magit-revision-show-gravatars + Whether to show gravatar images in revision buffers. + + If ‘nil’, then don’t insert any gravatar images. If ‘t’, then + insert both images. If ‘author’ or ‘committer’, then insert only + the respective image. + + If you have customized the option ‘magit-revision-headers-format’ + and want to insert the images then you might also have to specify + where to do so. In that case the value has to be a cons-cell of + two regular expressions. The car specifies where to insert the + author’s image. The top half of the image is inserted right after + the matched text, the bottom half on the next line in the same + column. The cdr specifies where to insert the committer’s image, + accordingly. Either the car or the cdr may be nil." + +User Option: magit-revision-use-hash-sections + Whether to turn hashes inside the commit message into sections. + + If non-nil, then hashes inside the commit message are turned into + ‘commit’ sections. There is a trade off to be made between + performance and reliability: + + • ‘slow’ calls git for every word to be absolutely sure. + • ‘quick’ skips words less than seven characters long. + • ‘quicker’ additionally skips words that don’t contain a + number. + • ‘quickest’ uses all words that are at least seven characters + long and which contain at least one number as well as at least + one letter. + + If nil, then no hashes are turned into sections, but you can still + visit the commit at point using "RET". + + The diffs shown in the revision buffer may be automatically +restricted to a subset of the changed files. If the revision buffer is +displayed from a log buffer, the revision buffer will share the same +file restriction as that log buffer (also see the command +‘magit-diff-toggle-file-filter’). + +User Option: magit-revision-filter-files-on-follow + Whether showing a commit from a log buffer honors the log’s file + filter when the log arguments include ‘--follow’. + + When this option is nil, displaying a commit from a log ignores the + log’s file filter if the log arguments include ‘--follow’. Doing + so avoids showing an empty diff in revision buffers for commits + before a rename event. In such cases, the ‘--patch’ argument of + the log transient can be used to show the file-restricted diffs + inline. + + Set this option to non-nil to keep the log’s file restriction even + if ‘--follow’ is present in the log arguments. + + If the revision buffer is not displayed from a log buffer, the file +restriction is determined as usual (see *note Transient Arguments and +Buffer Variables::). + + +File: doc5khxAZ.info, Node: Ediffing, Next: References Buffer, Prev: Diffing, Up: Inspecting + +5.5 Ediffing +============ + +This section describes how to enter Ediff from Magit buffers. For +information on how to use Ediff itself, see *note (ediff)Top::. + +Key: e (magit-ediff-dwim) + Compare, stage, or resolve using Ediff. + + This command tries to guess what file, and what commit or range the + user wants to compare, stage, or resolve using Ediff. It might + only be able to guess either the file, or range/commit, in which + case the user is asked about the other. It might not always guess + right, in which case the appropriate ‘magit-ediff-*’ command has to + be used explicitly. If it cannot read the user’s mind at all, then + it asks the user for a command to run. + +Key: E (magit-ediff) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: E r (magit-ediff-compare) + Compare two revisions of a file using Ediff. + + If the region is active, use the revisions on the first and last + line of the region. With a prefix argument, instead of diffing the + revisions, choose a revision to view changes along, starting at the + common ancestor of both revisions (i.e., use a "..." range). + +Key: E m (magit-ediff-resolve-rest) + This command allows you to resolve outstanding conflicts in the + file at point using Ediff. If there is no file at point or if it + doesn’t have any unmerged changes, then this command prompts for a + file. + + Provided that the value of ‘merge.conflictstyle’ is ‘diff3’, you + can view the file’s merge-base revision using ‘/’ in the Ediff + control buffer. + + The A, B and Ancestor buffers are constructed from the conflict + markers in the worktree file. Because you and/or Git may have + already resolved some conflicts, that means that these buffers may + not contain the actual versions from the respective blobs. + +Key: E M (magit-ediff-resolve-all) + This command allows you to resolve all conflicts in the file at + point using Ediff. If there is no file at point or if it doesn’t + have any unmerged changes, then this command prompts for a file. + + Provided that the value of ‘merge.conflictstyle’ is ‘diff3’, you + can view the file’s merge-base revision using ‘/’ in the Ediff + control buffer. + + First the file in the worktree is moved aside, appending the suffix + ‘.ORIG’, so that you could later go back to that version. Then it + is reconstructed from the two sides of the conflict and the + merge-base, if available. + + It would be nice if the worktree file were just used as-is, but + Ediff does not support that. This means that all conflicts, that + Git has already resolved, are restored. On the other hand Ediff + also tries to resolve conflicts, and in many cases Ediff and Git + should produce similar results. + + However if you have already resolved some conflicts manually, then + those changes are discarded (though you can recover them from the + backup file). In such cases ‘magit-ediff-resolve-rest’ might be + more suitable. + + The advantage that this command has over ‘magit-ediff-resolve-rest’ + is that the A, B and Ancestor buffers correspond to blobs from the + respective commits, allowing you to inspect a side in context and + to use Magit commands in these buffers to do so. Blame and log + commands are particularly useful here. + +Key: E t (magit-git-mergetool) + This command does not actually use Ediff. While it serves the same + purpose as ‘magit-ediff-resolve-rest’, it uses ‘git mergetool + --gui’ to resolve conflicts. + + With a prefix argument this acts as a transient prefix command, + allowing the user to select the mergetool and change some settings. + +Key: E s (magit-ediff-stage) + Stage and unstage changes to a file using Ediff, defaulting to the + file at point. + +Key: E u (magit-ediff-show-unstaged) + Show unstaged changes to a file using Ediff. + +Key: E i (magit-ediff-show-staged) + Show staged changes to a file using Ediff. + +Key: E w (magit-ediff-show-working-tree) + Show changes in a file between ‘HEAD’ and working tree using Ediff. + +Key: E c (magit-ediff-show-commit) + Show changes to a file introduced by a commit using Ediff. + +Key: E z (magit-ediff-show-stash) + Show changes to a file introduced by a stash using Ediff. + +User Option: magit-ediff-dwim-resolve-function + This option controls which function ‘magit-ediff-dwim’ uses to + resolve conflicts. One of ‘magit-ediff-resolve-rest’, + ‘magit-ediff-resolve-all’ or ‘magit-git-mergetool’; which are all + discussed above. + +User Option: magit-ediff-dwim-show-on-hunks + This option controls what command ‘magit-ediff-dwim’ calls when + point is on uncommitted hunks. When nil, always run + ‘magit-ediff-stage’. Otherwise, use ‘magit-ediff-show-staged’ and + ‘magit-ediff-show-unstaged’ to show staged and unstaged changes, + respectively. + +User Option: magit-ediff-show-stash-with-index + This option controls whether ‘magit-ediff-show-stash’ includes a + buffer containing the file’s state in the index at the time the + stash was created. This makes it possible to tell which changes in + the stash were staged. + +User Option: magit-ediff-quit-hook + This hook is run after quitting an Ediff session that was created + using a Magit command. The hook functions are run inside the Ediff + control buffer, and should not change the current buffer. + + This is similar to ‘ediff-quit-hook’ but takes the needs of Magit + into account. The regular ‘ediff-quit-hook’ is ignored by Ediff + sessions that were created using a Magit command. + + +File: doc5khxAZ.info, Node: References Buffer, Next: Bisecting, Prev: Ediffing, Up: Inspecting + +5.6 References Buffer +===================== + +Key: y (magit-show-refs) + This command lists branches and tags in a dedicated buffer. + + However if this command is invoked again from this buffer or if it + is invoked with a prefix argument, then it acts as a transient + prefix command, which binds the following suffix commands and some + infix arguments. + + All of the following suffix commands list exactly the same branches +and tags. The only difference the optional feature that can be enabled +by changing the value of ‘magit-refs-show-commit-count’ (see below). +These commands specify a different branch or commit against which all +the other references are compared. + +Key: y y (magit-show-refs-head) + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with ‘HEAD’. + +Key: y c (magit-show-refs-current) + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with the current branch or ‘HEAD’ if it + is detached. + +Key: y o (magit-show-refs-other) + This command lists branches and tags in a dedicated buffer. Each + reference is being compared with a branch read from the user. + +Key: y r (magit-refs-set-show-commit-count) + This command changes for which refs the commit count is shown. + +User Option: magit-refs-show-commit-count + Whether to show commit counts in Magit-Refs mode buffers. + + • ‘all’ Show counts for branches and tags. + • ‘branch’ Show counts for branches only. + • ‘nil’ Never show counts. + + The default is ‘nil’ because anything else can be very expensive. + +User Option: magit-refs-pad-commit-counts + Whether to pad all commit counts on all sides in Magit-Refs mode + buffers. + + If this is nil, then some commit counts are displayed right next to + one of the branches that appear next to the count, without any + space in between. This might look bad if the branch name faces + look too similar to ‘magit-dimmed’. + + If this is non-nil, then spaces are placed on both sides of all + commit counts. + +User Option: magit-refs-show-remote-prefix + Whether to show the remote prefix in lists of remote branches. + + Showing the prefix is redundant because the name of the remote is + already shown in the heading preceding the list of its branches. + +User Option: magit-refs-primary-column-width + Width of the primary column in ‘magit-refs-mode’ buffers. The + primary column is the column that contains the name of the branch + that the current row is about. + + If this is an integer, then the column is that many columns wide. + Otherwise it has to be a cons-cell of two integers. The first + specifies the minimal width, the second the maximal width. In that + case the actual width is determined using the length of the names + of the shown local branches. (Remote branches and tags are not + taken into account when calculating to optimal width.) + +User Option: magit-refs-focus-column-width + Width of the focus column in ‘magit-refs-mode’ buffers. + + The focus column is the first column, which marks one branch + (usually the current branch) as the focused branch using ‘*’ or + ‘@’. For each other reference, this column optionally shows how + many commits it is ahead of the focused branch and ‘<’, or if it + isn’t ahead then the commits it is behind and ‘>’, or if it isn’t + behind either, then a ‘=’. + + This column may also display only ‘*’ or ‘@’ for the focused + branch, in which case this option is ignored. Use ‘L v’ to change + the verbosity of this column. + +User Option: magit-refs-margin + This option specifies whether the margin is initially shown in + Magit-Refs mode buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + +User Option: magit-refs-margin-for-tags + This option specifies whether to show information about tags in the + margin. This is disabled by default because it is slow if there + are many tags. + + The following variables control how individual refs are displayed. +If you change one of these variables (especially the "%c" part), then +you should also change the others to keep things aligned. The following +%-sequences are supported: + + • ‘%a’ Number of commits this ref has over the one we compare to. + • ‘%b’ Number of commits the ref we compare to has over this one. + • ‘%c’ Number of commits this ref has over the one we compare to. + For the ref which all other refs are compared this is instead "@", + if it is the current branch, or "#" otherwise. + • ‘%C’ For the ref which all other refs are compared this is "@", if + it is the current branch, or "#" otherwise. For all other refs " + ". + • ‘%h’ Hash of this ref’s tip. + • ‘%m’ Commit summary of the tip of this ref. + • ‘%n’ Name of this ref. + • ‘%u’ Upstream of this local branch. + • ‘%U’ Upstream of this local branch and additional local vs. + upstream information. + +User Option: magit-refs-filter-alist + The purpose of this option is to forgo displaying certain refs + based on their name. If you want to not display any refs of a + certain type, then you should remove the appropriate function from + ‘magit-refs-sections-hook’ instead. + + This alist controls which tags and branches are omitted from being + displayed in ‘magit-refs-mode’ buffers. If it is ‘nil’, then all + refs are displayed (subject to ‘magit-refs-sections-hook’). + + All keys are tried in order until one matches. Then its value is + used and subsequent elements are ignored. If the value is non-nil, + then the reference is displayed, otherwise it is not. If no + element matches, then the reference is displayed. + + A key can either be a regular expression that the refname has to + match, or a function that takes the refname as only argument and + returns a boolean. A remote branch such as "origin/master" is + displayed as just "master", however for this comparison the former + is used. + +Key: RET (magit-visit-ref) + This command visits the reference or revision at point in another + buffer. If there is no revision at point or with a prefix argument + then it prompts for a revision. + + This command behaves just like ‘magit-show-commit’ as described + above, except if point is on a reference in a ‘magit-refs-mode’ + buffer, in which case the behavior may be different, but only if + you have customized the option ‘magit-visit-ref-behavior’. + +User Option: magit-visit-ref-behavior + This option controls how ‘magit-visit-ref’ behaves in + ‘magit-refs-mode’ buffers. + + By default ‘magit-visit-ref’ behaves like ‘magit-show-commit’, in + all buffers, including ‘magit-refs-mode’ buffers. When the type of + the section at point is ‘commit’ then "RET" is bound to + ‘magit-show-commit’, and when the type is either ‘branch’ or ‘tag’ + then it is bound to ‘magit-visit-ref’. + + "RET" is one of Magit’s most essential keys and at least by default + it should behave consistently across all of Magit, especially + because users quickly learn that it does something very harmless; + it shows more information about the thing at point in another + buffer. + + However "RET" used to behave differently in ‘magit-refs-mode’ + buffers, doing surprising things, some of which cannot really be + described as "visit this thing". If you’ve grown accustomed this + behavior, you can restore it by adding one or more of the below + symbols to the value of this option. But keep in mind that by + doing so you don’t only introduce inconsistencies, you also lose + some functionality and might have to resort to ‘M-x + magit-show-commit’ to get it back. + + ‘magit-visit-ref’ looks for these symbols in the order in which + they are described here. If the presence of a symbol applies to + the current situation, then the symbols that follow do not affect + the outcome. + + • ‘focus-on-ref’ + + With a prefix argument update the buffer to show commit counts + and lists of cherry commits relative to the reference at point + instead of relative to the current buffer or ‘HEAD’. + + Instead of adding this symbol, consider pressing "C-u y o + RET". + + • ‘create-branch’ + + If point is on a remote branch, then create a new local branch + with the same name, use the remote branch as its upstream, and + then check out the local branch. + + Instead of adding this symbol, consider pressing "b c RET + RET", like you would do in other buffers. + + • ‘checkout-any’ + + Check out the reference at point. If that reference is a tag + or a remote branch, then this results in a detached ‘HEAD’. + + Instead of adding this symbol, consider pressing "b b RET", + like you would do in other buffers. + + • ‘checkout-branch’ + + Check out the local branch at point. + + Instead of adding this symbol, consider pressing "b b RET", + like you would do in other buffers. + +* Menu: + +* References Sections:: + + +File: doc5khxAZ.info, Node: References Sections, Up: References Buffer + +5.6.1 References Sections +------------------------- + +The contents of references buffers is controlled using the hook +‘magit-refs-sections-hook’. See *note Section Hooks:: to learn about +such hooks and how to customize them. All of the below functions are +members of the default value. Note that it makes much less sense to +customize this hook than it does for the respective hook used for the +status buffer. + +User Option: magit-refs-sections-hook + Hook run to insert sections into a references buffer. + +Function: magit-insert-local-branches + Insert sections showing all local branches. + +Function: magit-insert-remote-branches + Insert sections showing all remote-tracking branches. + +Function: magit-insert-tags + Insert sections showing all tags. + + +File: doc5khxAZ.info, Node: Bisecting, Next: Visiting Files and Blobs, Prev: References Buffer, Up: Inspecting + +5.7 Bisecting +============= + +Also see [BROKEN LINK: man:git-bisect] + +Key: B (magit-bisect) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + When bisecting is not in progress, then the transient features the +following suffix commands. + +Key: B B (magit-bisect-start) + Start a bisect session. + + Bisecting a bug means to find the commit that introduced it. This + command starts such a bisect session by asking for a known good + commit and a known bad commit. If you’re bisecting a change that + isn’t a regression, you can select alternate terms that are + conceptually more fitting than "bad" and "good", but the infix + arguments to do so are disabled by default. + +Key: B s (magit-bisect-run) + Bisect automatically by running commands after each step. + + When bisecting in progress, then the transient instead features the +following suffix commands. + +Key: B b (magit-bisect-bad) + Mark the current commit as bad. Use this after you have asserted + that the commit does contain the bug in question. + +Key: B g (magit-bisect-good) + Mark the current commit as good. Use this after you have asserted + that the commit does not contain the bug in question. + +Key: B m (magit-bisect-mark) + Mark the current commit with one of the bisect terms. This command + provides an alternative to ‘magit-bisect-bad’ and + ‘magit-bisect-good’ and is useful when using terms other than "bad" + and "good". This suffix is disabled by default. + +Key: B k (magit-bisect-skip) + Skip the current commit. Use this if for some reason the current + commit is not a good one to test. This command lets Git choose a + different one. + +Key: B r (magit-bisect-reset) + After bisecting, cleanup bisection state and return to original + ‘HEAD’. + + By default the status buffer shows information about the ongoing +bisect session. + +User Option: magit-bisect-show-graph + This option controls whether a graph is displayed for the log of + commits that still have to be bisected. + + +File: doc5khxAZ.info, Node: Visiting Files and Blobs, Next: Blaming, Prev: Bisecting, Up: Inspecting + +5.8 Visiting Files and Blobs +============================ + +Magit provides several commands that visit a file or blob (the version +of a file that is stored in a certain commit). Actually it provides +several *groups* of such commands and the several *variants* within each +group. + + Also see *note Commands for Buffers Visiting Files::. + +* Menu: + +* General-Purpose Visit Commands:: +* Visiting Files and Blobs from a Diff:: + + +File: doc5khxAZ.info, Node: General-Purpose Visit Commands, Next: Visiting Files and Blobs from a Diff, Up: Visiting Files and Blobs + +5.8.1 General-Purpose Visit Commands +------------------------------------ + +These commands can be used anywhere to open any blob. Currently no keys +are bound to these commands by default, but that is likely to change. + +Command: magit-find-file + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in the + selected window. + +Command: magit-find-file-other-window + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in + another window. + +Command: magit-find-file-other-frame + This command reads a filename and revision from the user and visits + the respective blob in a buffer. The buffer is displayed in + another frame. + + +File: doc5khxAZ.info, Node: Visiting Files and Blobs from a Diff, Prev: General-Purpose Visit Commands, Up: Visiting Files and Blobs + +5.8.2 Visiting Files and Blobs from a Diff +------------------------------------------ + +These commands can only be used when point is inside a diff. + +Key: RET (magit-diff-visit-file) + This command visits the appropriate version of the file that the + diff at point is about. The location of point inside the diff + determines which file is being visited. The visited version + depends on what changes the diff is about. + + 1. If the diff shows uncommitted changes (i.e., staged or + unstaged changes), then visit the file in the working tree + (i.e., the same "real" file that ‘find-file’ would visit. In + all other cases visit a "blob" (i.e., the version of a file as + stored in some commit). + + 2. If point is on a removed line, then visit the blob for the + first parent of the commit that removed that line, i.e., the + last commit where that line still exists. + + 3. If point is on an added or context line, then visit the blob + that adds that line, or if the diff shows from more than a + single commit, then visit the blob from the last of these + commits. + + In the file-visiting buffer this command goes to the line that + corresponds to the line that point is on in the diff. + + The buffer is displayed in the selected window. With a prefix + argument the buffer is displayed in another window instead. + +User Option: magit-diff-visit-previous-blob + This option controls whether ‘magit-diff-visit-file’ may visit the + previous blob. When this is ‘t’ (the default) and point is on a + removed line in a diff for a committed change, then + ‘magit-diff-visit-file’ visits the blob from the last revision + which still had that line. + + Currently this is only supported for committed changes, for staged + and unstaged changes ‘magit-diff-visit-file’ always visits the file + in the working tree. + +Key: C- (magit-diff-visit-file-worktree) + This command visits the worktree version of the appropriate file. + The location of point inside the diff determines which file is + being visited. Unlike ‘magit-diff-visit-file’ it always visits the + "real" file in the working tree, i.e the "current version" of the + file. + + In the file-visiting buffer this command goes to the line that + corresponds to the line that point is on in the diff. Lines that + were added or removed in the working tree, the index and other + commits in between are automatically accounted for. + + The buffer is displayed in the selected window. With a prefix + argument the buffer is displayed in another window instead. + + Variants of the above two commands exist that instead visit the file +in another window or in another frame. If you prefer such behavior, +then you may want to change the above key bindings, but note that the +above commands also use another window when invoked with a prefix +argument. + +Command: magit-diff-visit-file-other-window + +Command: magit-diff-visit-file-other-frame + +Command: magit-diff-visit-worktree-file-other-window + +Command: magit-diff-visit-worktree-file-other-frame + + +File: doc5khxAZ.info, Node: Blaming, Prev: Visiting Files and Blobs, Up: Inspecting + +5.9 Blaming +=========== + +Also see [BROKEN LINK: man:git-blame] + + To start blaming, invoke the ‘magit-file-dispatch’ transient prefix +command. When using the default key bindings, that can be done by +pressing ‘C-c M-g’. When using the recommended bindings, this command +is instead bound to ‘C-c f’. Also see *note Global Bindings::. + + The blaming suffix commands can be invoked directly from the file +dispatch transient. However if you want to set an infix argument, then +you have to enter the blaming sub-prefix first. + +Key: C-c f B (magit-blame) + +Key: C-c f b (magit-blame-addition) + +Key: C-c f B b + +Key: C-c f r (magit-blame-removal) + +Key: C-c f B r + +Key: C-c f f (magit-blame-reverse) + +Key: C-c f B f + +Key: C-c f e (magit-blame-echo) + +Key: C-c f B e + +Key: C-c f q (magit-blame-quit) + +Key: C-c f B q + Each of these commands is documented individually right below, + alongside their default key bindings. The bindings shown above are + the recommended bindings, which you can enable by following the + instructions in *note Global Bindings::. + +Key: C-c M-g B (magit-blame) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + Note that not all of the following suffixes are available at all +times. For example if ‘magit-blame-mode’ is not enabled, then the +command whose purpose is to turn off that mode would not be of any use +and therefore isn’t available. + +Key: C-c M-g b (magit-blame-addition) + +Key: C-c M-g B b + This command augments each line or chunk of lines in the current + file-visiting or blob-visiting buffer with information about what + commits last touched these lines. + + If the buffer visits a revision of that file, then history up to + that revision is considered. Otherwise, the file’s full history is + considered, including uncommitted changes. + + If Magit-Blame mode is already turned on in the current buffer then + blaming is done recursively, by visiting REVISION:FILE (using + ‘magit-find-file’), where REVISION is a parent of the revision that + added the current line or chunk of lines. + +Key: C-c M-g r (magit-blame-removal) + +Key: C-c M-g B r + This command augments each line or chunk of lines in the current + blob-visiting buffer with information about the revision that + removes it. It cannot be used in file-visiting buffers. + + Like ‘magit-blame-addition’, this command can be used recursively. + +Key: C-c M-g f (magit-blame-reverse) + +Key: C-c M-g B f + This command augments each line or chunk of lines in the current + file-visiting or blob-visiting buffer with information about the + last revision in which a line still existed. + + Like ‘magit-blame-addition’, this command can be used recursively. + +Key: C-c M-g e (magit-blame-echo) + +Key: C-c M-g B e + This command is like ‘magit-blame-addition’ except that it doesn’t + turn on ‘read-only-mode’ and that it initially uses the + visualization style specified by option ‘magit-blame-echo-style’. + + The following key bindings are available when Magit-Blame mode is +enabled and Read-Only mode is not enabled. These commands are also +available in other buffers; here only the behavior is described that is +relevant in file-visiting buffers that are being blamed. + +Key: C-c M-g q (magit-blame-quit) + +Key: C-c M-g B q + This command turns off Magit-Blame mode. If the buffer was created + during a recursive blame, then it also kills the buffer. + +Key: RET (magit-show-commit) + This command shows the commit that last touched the line at point. + +Key: SPC (magit-diff-show-or-scroll-up) + This command updates the commit buffer. + + This either shows the commit that last touched the line at point in + the appropriate buffer, or if that buffer is already being + displayed in the current frame and if that buffer contains + information about that commit, then the buffer is scrolled up + instead. + +Key: DEL (magit-diff-show-or-scroll-down) + This command updates the commit buffer. + + This either shows the commit that last touched the line at point in + the appropriate buffer, or if that buffer is already being + displayed in the current frame and if that buffer contains + information about that commit, then the buffer is scrolled down + instead. + + The following key bindings are available when both Magit-Blame mode +and Read-Only mode are enabled. + +Key: b (magit-blame) + See above. + +Key: n (magit-blame-next-chunk) + This command moves to the next chunk. + +Key: N (magit-blame-next-chunk-same-commit) + This command moves to the next chunk from the same commit. + +Key: p (magit-blame-previous-chunk) + This command moves to the previous chunk. + +Key: P (magit-blame-previous-chunk-same-commit) + This command moves to the previous chunk from the same commit. + +Key: q (magit-blame-quit) + This command turns off Magit-Blame mode. If the buffer was created + during a recursive blame, then it also kills the buffer. + +Key: M-w (magit-blame-copy-hash) + This command saves the hash of the current chunk’s commit to the + kill ring. + + When the region is active, the command saves the region’s content + instead of the hash, like ‘kill-ring-save’ would. + +Key: c (magit-blame-cycle-style) + This command changes how blame information is visualized in the + current buffer by cycling through the styles specified using the + option ‘magit-blame-styles’. + + Blaming is also controlled using the following options. + +User Option: magit-blame-styles + This option defines a list of styles used to visualize blame + information. For now see its doc-string to learn more. + +User Option: magit-blame-echo-style + This option specifies the blame visualization style used by the + command ‘magit-blame-echo’. This must be a symbol that is used as + the identifier for one of the styles defined in + ‘magit-blame-styles’. + +User Option: magit-blame-time-format + This option specifies the format string used to display times when + showing blame information. + +User Option: magit-blame-read-only + This option controls whether blaming a buffer also makes + temporarily read-only. + +User Option: magit-blame-disable-modes + This option lists incompatible minor-modes that should be disabled + temporarily when a buffer contains blame information. They are + enabled again when the buffer no longer shows blame information. + +User Option: magit-blame-goto-chunk-hook + This hook is run when moving between chunks. + + +File: doc5khxAZ.info, Node: Manipulating, Next: Transferring, Prev: Inspecting, Up: Top + +6 Manipulating +************** + +* Menu: + +* Creating Repository:: +* Cloning Repository:: +* Staging and Unstaging:: +* Applying:: +* Committing:: +* Branching:: +* Merging:: +* Resolving Conflicts:: +* Rebasing:: +* Cherry Picking:: +* Resetting:: +* Stashing:: + + +File: doc5khxAZ.info, Node: Creating Repository, Next: Cloning Repository, Up: Manipulating + +6.1 Creating Repository +======================= + +Key: I (magit-init) + This command initializes a repository and then shows the status + buffer for the new repository. + + If the directory is below an existing repository, then the user has + to confirm that a new one should be created inside. If the + directory is the root of the existing repository, then the user has + to confirm that it should be reinitialized. + + +File: doc5khxAZ.info, Node: Cloning Repository, Next: Staging and Unstaging, Prev: Creating Repository, Up: Manipulating + +6.2 Cloning Repository +====================== + +To clone a remote or local repository use ‘C’, which is bound to the +command ‘magit-clone’. This command either act as a transient prefix +command, which binds several infix arguments and suffix commands, or it +can invoke ‘git clone’ directly, depending on whether a prefix argument +is used and on the value of ‘magit-clone-always-transient’. + +User Option: magit-clone-always-transient + This option controls whether the command ‘magit-clone’ always acts + as a transient prefix command, regardless of whether a prefix + argument is used or not. If ‘t’, then that command always acts as + a transient prefix. If ‘nil’, then a prefix argument has to be + used for it to act as a transient. + +Key: C (magit-clone) + This command either acts as a transient prefix command as described + above or does the same thing as ‘transient-clone-regular’ as + described below. + + If it acts as a transient prefix, then it binds the following + suffix commands and several infix arguments. + +Key: C C (magit-clone-regular) + This command creates a regular clone of an existing repository. + The repository and the target directory are read from the user. + +Key: C s (magit-clone-shallow) + This command creates a shallow clone of an existing repository. + The repository and the target directory are read from the user. By + default the depth of the cloned history is a single commit, but + with a prefix argument the depth is read from the user. + +Key: C > (magit-clone-sparse) + This command creates a clone of an existing repository and + initializes a sparse checkout, avoiding a checkout of the full + working tree. To add more directories, use the + ‘magit-sparse-checkout’ transient (see *note Sparse checkouts::). + +Key: C b (magit-clone-bare) + This command creates a bare clone of an existing repository. The + repository and the target directory are read from the user. + +Key: C m (magit-clone-mirror) + This command creates a mirror of an existing repository. The + repository and the target directory are read from the user. + + The following suffixes are disabled by default. See *note +(transient)Enabling and Disabling Suffixes:: for how to enable them. + +Key: C d (magit-clone-shallow-since) + This command creates a shallow clone of an existing repository. + Only commits that were committed after a date are cloned, which is + read from the user. The repository and the target directory are + also read from the user. + +Key: C e (magit-clone-shallow-exclude) + This command creates a shallow clone of an existing repository. + This reads a branch or tag from the user. Commits that are + reachable from that are not cloned. The repository and the target + directory are also read from the user. + +User Option: magit-clone-set-remote-head + This option controls whether cloning causes the reference + ‘refs/remotes//HEAD’ to be created in the clone. The + default is to delete the reference after running ‘git clone’, which + insists on creating it. This is because the reference has not been + found to be particularly useful as it is not automatically updated + when the ‘HEAD’ of the remote changes. Setting this option to ‘t’ + preserves Git’s default behavior of creating the reference. + +User Option: magit-clone-set-remote.pushDefault + This option controls whether the value of the Git variable + ‘remote.pushDefault’ is set after cloning. + + • If ‘t’, then it is always set without asking. + • If ‘ask’, then the users are asked every time they clone a + repository. + • If ‘nil’, then it is never set. + +User Option: magit-clone-default-directory + This option control the default directory name used when reading + the destination for a cloning operation. + + • If ‘nil’ (the default), then the value of ‘default-directory’ + is used. + • If a directory, then that is used. + • If a function, then that is called with the remote url as the + only argument and the returned value is used. + +User Option: magit-clone-name-alist + This option maps regular expressions, which match repository names, + to repository urls, making it possible for users to enter short + names instead of urls when cloning repositories. + + Each element has the form ‘(REGEXP HOSTNAME USER)’. When the user + enters a name when a cloning command asks for a name or url, then + that is looked up in this list. The first element whose REGEXP + matches is used. + + The format specified by option ‘magit-clone-url-format’ is used to + turn the name into an url, using HOSTNAME and the repository name. + If the provided name contains a slash, then that is used. + Otherwise if the name omits the owner of the repository, then the + default user specified in the matched entry is used. + + If USER contains a dot, then it is treated as a Git variable and + the value of that is used as the username. Otherwise it is used as + the username itself. + +User Option: magit-clone-url-format + The format specified by this option is used when turning repository + names into urls. ‘%h’ is the hostname and ‘%n’ is the repository + name, including the name of the owner. The value can be a string + (representing a single static format) or an alist with elements + ‘(HOSTNAME . FORMAT)’ mapping hostnames to formats. When an alist + is used, the ‘t’ key represents the default format. + + Example of a single format string: + + (setq magit-clone-url-format + "git@%h:%n.git") + + Example of by-hostname format strings: + + (setq magit-clone-url-format + '(("git.example.com" . "git@%h:~%n") + (nil . "git@%h:%n.git"))) + +User Option: magit-post-clone-hook + Hook run after the Git process has successfully finished cloning + the repository. When the hook is called, ‘default-directory’ is + let-bound to the directory where the repository has been cloned. + + +File: doc5khxAZ.info, Node: Staging and Unstaging, Next: Applying, Prev: Cloning Repository, Up: Manipulating + +6.3 Staging and Unstaging +========================= + +Like Git, Magit can of course stage and unstage complete files. Unlike +Git, it also allows users to gracefully un-/stage individual hunks and +even just part of a hunk. To stage individual hunks and parts of hunks +using Git directly, one has to use the very modal and rather clumsy +interface of a ‘git add --interactive’ session. + + With Magit, on the other hand, one can un-/stage individual hunks by +just moving point into the respective section inside a diff displayed in +the status buffer or a separate diff buffer and typing ‘s’ or ‘u’. To +operate on just parts of a hunk, mark the changes that should be +un-/staged using the region and then press the same key that would be +used to un-/stage. To stage multiple files or hunks at once use a +region that starts inside the heading of such a section and ends inside +the heading of a sibling section of the same type. + + Besides staging and unstaging, Magit also provides several other +"apply variants" that can also operate on a file, multiple files at +once, a hunk, multiple hunks at once, and on parts of a hunk. These +apply variants are described in the next section. + + You can also use Ediff to stage and unstage. See *note Ediffing::. + +Key: s (magit-stage) + Add the change at point to the staging area. + + With a prefix argument and an untracked file (or files) at point, + stage the file but not its content. This makes it possible to + stage only a subset of the new file’s changes. + +Key: S (magit-stage-modified) + Stage all changes to files modified in the worktree. Stage all new + content of tracked files and remove tracked files that no longer + exist in the working tree from the index also. With a prefix + argument also stage previously untracked (but not ignored) files. + +Key: u (magit-unstage) + Remove the change at point from the staging area. + + Only staged changes can be unstaged. But by default this command + performs an action that is somewhat similar to unstaging, when it + is called on a committed change: it reverses the change in the + index but not in the working tree. + +Key: U (magit-unstage-all) + Remove all changes from the staging area. + +User Option: magit-unstage-committed + This option controls whether ‘magit-unstage’ "unstages" committed + changes by reversing them in the index but not the working tree. + The alternative is to raise an error. + +Key: M-x magit-reverse-in-index + This command reverses the committed change at point in the index + but not the working tree. By default no key is bound directly to + this command, but it is indirectly called when ‘u’ + (‘magit-unstage’) is pressed on a committed change. + + This allows extracting a change from ‘HEAD’, while leaving it in + the working tree, so that it can later be committed using a + separate commit. A typical workflow would be: + + 1. Optionally make sure that there are no uncommitted changes. + 2. Visit the ‘HEAD’ commit and navigate to the change that should + not have been included in that commit. + 3. Type ‘u’ (‘magit-unstage’) to reverse it in the index. This + assumes that ‘magit-unstage-committed’ is non-nil. + 4. Type ‘c e’ to extend ‘HEAD’ with the staged changes, including + those that were already staged before. + 5. Optionally stage the remaining changes using ‘s’ or ‘S’ and + then type ‘c c’ to create a new commit. + +Key: M-x magit-reset-index + Reset the index to some commit. The commit is read from the user + and defaults to the commit at point. If there is no commit at + point, then it defaults to ‘HEAD’. + +* Menu: + +* Staging from File-Visiting Buffers:: + + +File: doc5khxAZ.info, Node: Staging from File-Visiting Buffers, Up: Staging and Unstaging + +6.3.1 Staging from File-Visiting Buffers +---------------------------------------- + +Fine-grained un-/staging has to be done from the status or a diff +buffer, but it’s also possible to un-/stage all changes made to the file +visited in the current buffer right from inside that buffer. + +Key: M-x magit-stage-file + When invoked inside a file-visiting buffer, then stage all changes + to that file. In a Magit buffer, stage the file at point if any. + Otherwise prompt for a file to be staged. With a prefix argument + always prompt the user for a file, even in a file-visiting buffer + or when there is a file section at point. + +Key: M-x magit-unstage-file + When invoked inside a file-visiting buffer, then unstage all + changes to that file. In a Magit buffer, unstage the file at point + if any. Otherwise prompt for a file to be unstaged. With a prefix + argument always prompt the user for a file, even in a file-visiting + buffer or when there is a file section at point. + + +File: doc5khxAZ.info, Node: Applying, Next: Committing, Prev: Staging and Unstaging, Up: Manipulating + +6.4 Applying +============ + +Magit provides several "apply variants": stage, unstage, discard, +reverse, and "regular apply". At least when operating on a hunk they +are all implemented using ‘git apply’, which is why they are called +"apply variants". + + • Stage. Apply a change from the working tree to the index. The + change also remains in the working tree. + + • Unstage. Remove a change from the index. The change remains in + the working tree. + + • Discard. On a staged change, remove it from the working tree and + the index. On an unstaged change, remove it from the working tree + only. + + • Reverse. Reverse a change in the working tree. Both committed and + staged changes can be reversed. Unstaged changes cannot be + reversed. Discard them instead. + + • Apply. Apply a change to the working tree. Both committed and + staged changes can be applied. Unstaged changes cannot be applied + - as they already have been applied. + + The previous section described the staging and unstaging commands. +What follows are the commands which implement the remaining apply +variants. + +Key: a (magit-apply) + Apply the change at point to the working tree. + + With a prefix argument fallback to a 3-way merge. Doing so causes + the change to be applied to the index as well. + +Key: k (magit-discard) + Remove the change at point from the working tree. + + On a hunk or file with unresolved conflicts prompt which side to + keep (while discarding the other). If point is within the text of + a side, then keep that side without prompting. + +Key: v (magit-reverse) + Reverse the change at point in the working tree. + + With a prefix argument fallback to a 3-way merge. Doing so causes + the change to be applied to the index as well. + + With a prefix argument all apply variants attempt a 3-way merge when +appropriate (i.e., when ‘git apply’ is used internally). + + +File: doc5khxAZ.info, Node: Committing, Next: Branching, Prev: Applying, Up: Manipulating + +6.5 Committing +============== + +When the user initiates a commit, Magit calls ‘git commit’ without the +‘--message’ argument, so Git has to get the message from the user. To +do so, it creates a file such as ‘.git/COMMIT_EDITMSG’ and then opens +that file in the editor specified by ‘$EDITOR’ (or ‘$GIT_EDITOR’). + + Magit arranges for that editor to be the Emacsclient. Once the user +finishes the editing session, the Emacsclient exits and Git creates the +commit, using the file’s content as the commit message. + +* Menu: + +* Initiating a Commit:: +* Editing Commit Messages:: + + +File: doc5khxAZ.info, Node: Initiating a Commit, Next: Editing Commit Messages, Up: Committing + +6.5.1 Initiating a Commit +------------------------- + +Also see [BROKEN LINK: man:git-commit] + +Key: c (magit-commit) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +* Menu: + +* Creating a new commit:: +* Editing the last commit:: +* Editing any reachable commit:: +* Editing any reachable commit and rebasing immediately:: +* Options used by commit commands:: + + +File: doc5khxAZ.info, Node: Creating a new commit, Next: Editing the last commit, Up: Initiating a Commit + +Creating a new commit +..................... + +Key: c c (magit-commit-create) + Create a new commit. + + +File: doc5khxAZ.info, Node: Editing the last commit, Next: Editing any reachable commit, Prev: Creating a new commit, Up: Initiating a Commit + +Editing the last commit +....................... + +These commands modify the last (a.k.a., "HEAD") commit. The commit is +modified (a.k.a., replaced) immediately. Similar commands exist for +modifying other (non-HEAD) commits. Those commands are described in the +following two sections. For each command in this section, we mention +the respective non-HEAD commands, to make the relation explicit. + + The command descriptions below mention the specific arguments they +use when calling ‘git commit’. The arguments specified in the menu are +appended to those arguments. + +Key: c e (magit-commit-extend) + This command amends the staged changes to the last commit, without + editing its commit message. + + This command calls ‘git commit --amend --no-edit’. + + With a prefix argument the committer date is not updated; without + an argument it is updated. + + The option ‘magit-commit-extend-override-date’ can be used to + inverse the meaning of the prefix argument. Non-interactively, the + optional OVERRIDE-DATE argument controls this behavior, and the + option is of no relevance. + +Key: c a (magit-commit-amend) + This command amends the staged changes to the last commit, and pops + up a buffer to let the user edit its commit message. + + This command calls ‘git commit --amend --edit’. + +Key: c w (magit-commit-reword) + This command pops up a buffer to let the user edit the message of + the latest commit. The commit tree remains unchanged and staged + changes remain staged. + + This command calls ‘git commit --amend --only --edit’. + + With a prefix argument the committer date is not updated; without + an argument it is updated. + + The option ‘magit-commit-reword-override-date’ can be used to + inverse the meaning of the prefix argument. Non-interactively, the + optional OVERRIDE-DATE argument controls this behavior, and the + option is of no relevance. + + +File: doc5khxAZ.info, Node: Editing any reachable commit, Next: Editing any reachable commit and rebasing immediately, Prev: Editing the last commit, Up: Initiating a Commit + +Editing any reachable commit +............................ + +These commands create a new commit, which targets an existing commit, +from the staged changes and/or using a new commit message. Any commit +that is reachable from HEAD, including HEAD itself, can be the target. + + The new commit is intended to be eventually squashed into the +targeted commit, but this is *not* done immediately. The squashing is +done at a later time, when you explicitly call +‘magit-rebase-autosquash’, or use ‘--autosquash’ with another rebase +command. + + Some of these commands require that you immediately write a new +commit message, or that you immediately edit an existing message. + + The new commits are called "squash" and "fixup" commits. The +difference is that when a "squash" commit is squashed into its targeted +commit, the user gets a chance to modify the message to be used for the +final commit; while for "fixup" commits the existing message of the +targeted commit is used as-is and the message of the "fixup" commit is +discarded. + + If point is on a reachable commit, then all of these commands target +that commit, without requiring confirmation. If point is on some +reachable commit, but you want to target another commit, use a prefix +argument, to select a commit in a log buffer dedicated to that task. +The meaning of the prefix argument can be inverted by customizing +‘magit-commit-squash-confirm’. + + The command descriptions below mention the specific arguments they +use when calling ‘git commit’. The arguments specified in the menu are +appended to those arguments. + + The next two commands also exist in "instant" variants, which are +described in the next section. Those variants behave the same as the +variants described here, except that they immediately initiate an +‘--autosquash’ rebase. + +Key: c f (magit-commit-fixup) + This command creates a new fixup commit from the staged changes, + targeting the reachable commit at point, if any. Otherwise the + user is prompted for a commit. + + Use this variant if you want to correct some minor defect in the + targeted commit, which does not require changes to the existing + message of the targeted commit. + + This command calls ‘git commit --fixup=COMMIT --no-edit’. + +Key: c s (magit-commit-squash) + This command creates a new squash commit from the staged changes, + targeting the reachable commit at point, if any. Otherwise the + user is prompted for a commit. + + Use this variant if you want a chance to make changes to the final + commit message, but not until the two commits are being squashed + into the final combined commit. + + This command calls ‘git commit --squash=COMMIT --no-edit’. + +Key: c A (magit-commit-alter) + This command creates a new fixup commit from the staged changes, + targeting the reachable commit at point, if any. Otherwise the + user is prompted for a commit. + + Use this variant if you want to write the final commit message now, + but (as for all variants in this section) do not want to + immediately squash the fixup and targeted commits into a final + combined commit. + + This command calls ‘git commit --fixup=amend:COMMIT --edit’. + +Key: c n (magit-commit-augment) + This command creates a new squash commit from the staged changes, + targeting the reachable commit at point, if any. Otherwise the + user is prompted for a commit. + + Use this variant if you want to describe the new changes now, but + want to delay writing the final message, which describes the + changes in the combined commit, until you actually combine the + squash and target commits into the final commit. You can think of + the new message, which you write here, as a "note", to be + integrated once once you write the final commit message. + + This command calls ‘git commit --squash=COMMIT --edit’. + +Key: c W (magit-commit-revise) + This command pops up a buffer containing the commit message of the + reachable commit at point, if any. Otherwise the user is prompted + for a commit to target. + + Use this variant if you want to correct the message of the targeted + commit, but want to delay performing the ‘--autosquash’ rebase, + which actually changes that commit. + + This command calls ‘git commit --fixup=reword:COMMIT --edit’. + + +File: doc5khxAZ.info, Node: Editing any reachable commit and rebasing immediately, Next: Options used by commit commands, Prev: Editing any reachable commit, Up: Initiating a Commit + +Editing any reachable commit and rebasing immediately +..................................................... + +These commands create a new commit, which targets an existing commit, +from the staged changes. Any commit that is reachable from HEAD, +including HEAD itself, can be the target. + + The new commit is immediately squashed into its target commit, using +an ‘--autosquash’ rebase. + + The command descriptions below mention the specific arguments they +use when calling ‘git commit’. The arguments specified in the menu are +appended to those arguments when calling ‘git commit’. + +Key: c F (magit-commit-instant-fixup) + This command creates a fixup commit, targeting the reachable commit + at point, if any. Otherwise the user is prompted for a commit. + Then it instantly performs a rebase, to squash the new commit into + the targeted commit. + + The original commit message of the targeted commit is left + untouched. + + This command calls ‘git commit --fixup=COMMIT --no-edit’ and then + ‘git rebase --autosquash MERGE-BASE’. + +Key: c S (magit-commit-instant-squash) + This command creates a squash commit, targeting the reachable + commit at point, if any. Otherwise the user is prompted for a + commit. Then it instantly performs a rebase, to squash the new + commit into the targeted commit. + + During the rebase phase the user is asked to author the final + commit message, based on the original message of the targeted + commit. + + This command calls ‘git commit --squash=COMMIT --no-edit’ and then + ‘git rebase --autosquash MERGE-BASE’. + + +File: doc5khxAZ.info, Node: Options used by commit commands, Prev: Editing any reachable commit and rebasing immediately, Up: Initiating a Commit + +Options used by commit commands +............................... + + • Used by all or most commit commands + + User Option: magit-commit-show-diff + Whether the relevant diff is automatically shown when + committing. + + User Option: magit-commit-ask-to-stage + Whether to ask to stage all unstaged changes when committing + and nothing is staged. + + User Option: magit-post-commit-hook + Hook run after creating a commit without the user editing a + message. + + This hook is run by ‘magit-refresh’ if ‘this-command’ is a + member of ‘magit-post-commit-hook-commands’. This only + includes commands named ‘magit-commit-*’ that do *not* require + that the user edits the commit message in a buffer. + + Also see ‘git-commit-post-finish-hook’. + + User Option: magit-commit-diff-inhibit-same-window + Whether to inhibit use of same window when showing diff while + committing. + + When writing a commit, then a diff of the changes to be + committed is automatically shown. The idea is that the diff + is shown in a different window of the same frame and for most + users that just works. In other words most users can + completely ignore this option because its value doesn’t make a + difference for them. + + However for users who configured Emacs to never create a new + window even when the package explicitly tries to do so, then + displaying two new buffers necessarily means that the first is + immediately replaced by the second. In our case the message + buffer is immediately replaced by the diff buffer, which is of + course highly undesirable. + + A workaround is to suppress this user configuration in this + particular case. Users have to explicitly opt-in by toggling + this option. We cannot enable the workaround unconditionally + because that again causes issues for other users: if the frame + is too tiny or the relevant settings too aggressive, then the + diff buffer would end up being displayed in a new frame. + + Also see . + + • Used by all squash and fixup commands + + User Option: magit-commit-squash-confirm + Whether the commit targeted by squash and fixup has to be + confirmed. When non-nil then the commit at point (if any) is + used as default choice. Otherwise it has to be confirmed. + This option only affects ‘magit-commit-squash’ and + ‘magit-commit-fixup’. The "instant" variants always require + confirmation because making an error while using those is + harder to recover from. + + • Used by specific commit commands + + User Option: magit-commit-extend-override-date + Whether using ‘magit-commit-extend’ changes the committer + date. + + User Option: magit-commit-reword-override-date + Whether using ‘magit-commit-reword’ changes the committer + date. + + +File: doc5khxAZ.info, Node: Editing Commit Messages, Prev: Initiating a Commit, Up: Committing + +6.5.2 Editing Commit Messages +----------------------------- + +After initiating a commit as described in the previous section, two new +buffers appear. One shows the changes that are about to be committed, +while the other is used to write the message. + + Commit messages are edited in an edit session - in the background +‘git’ is waiting for the editor, in our case ‘emacsclient’, to save the +commit message in a file (in most cases ‘.git/COMMIT_EDITMSG’) and then +return. If the editor returns with a non-zero exit status then ‘git’ +does not create the commit. So the most important commands are those +for finishing and aborting the commit. + +Key: C-c C-c (with-editor-finish) + Finish the current editing session by returning with exit code 0. + Git then creates the commit using the message it finds in the file. + +Key: C-c C-k (with-editor-cancel) + Cancel the current editing session by returning with exit code 1. + Git then cancels the commit, but leaves the file untouched. + + In addition to being used by ‘git commit’, messages may also be +stored in a ring that persists until Emacs is closed. By default the +message is stored at the beginning and the end of an edit session +(regardless of whether the session is finished successfully or was +canceled). It is sometimes useful to bring back messages from that +ring. + +Key: C-c M-s (git-commit-save-message) + Save the current buffer content to the commit message ring. + +Key: M-p (git-commit-prev-message) + Cycle backward through the commit message ring, after saving the + current message to the ring. With a numeric prefix ARG, go back + ARG comments. + +Key: M-n (git-commit-next-message) + Cycle forward through the commit message ring, after saving the + current message to the ring. With a numeric prefix ARG, go back + ARG comments. + + By default the diff for the changes that are about to be committed +are automatically shown when invoking the commit. To prevent that, +remove ‘magit-commit-diff’ from ‘server-switch-hook’. + + When amending to an existing commit it may be useful to show either +the changes that are about to be added to that commit or to show those +changes alongside those that have already been committed. + +Key: C-c C-d (magit-diff-while-committing) + While committing, show the changes that are about to be committed. + While amending, invoking the command again toggles between showing + just the new changes or all the changes that will be committed. + +* Menu: + +* Using the Revision Stack:: +* Commit Pseudo Headers:: +* Commit Mode and Hooks:: +* Commit Message Conventions:: + + +File: doc5khxAZ.info, Node: Using the Revision Stack, Next: Commit Pseudo Headers, Up: Editing Commit Messages + +Using the Revision Stack +........................ + +Key: C-c C-w (magit-pop-revision-stack) + This command inserts a representation of a revision into the + current buffer. It can be used inside buffers used to write commit + messages but also in other buffers such as buffers used to edit + emails or ChangeLog files. + + By default this command pops the revision which was last added to + the ‘magit-revision-stack’ and inserts it into the current buffer + according to ‘magit-pop-revision-stack-format’. Revisions can be + put on the stack using ‘magit-copy-section-value’ and + ‘magit-copy-buffer-revision’. + + If the stack is empty or with a prefix argument it instead reads a + revision in the minibuffer. By using the minibuffer history this + allows selecting an item which was popped earlier or to insert an + arbitrary reference or revision without first pushing it onto the + stack. + + When reading the revision from the minibuffer, then it might not be + possible to guess the correct repository. When this command is + called inside a repository (e.g., while composing a commit + message), then that repository is used. Otherwise (e.g., while + composing an email) then the repository recorded for the top + element of the stack is used (even though we insert another + revision). If not called inside a repository and with an empty + stack, or with two prefix arguments, then read the repository in + the minibuffer too. + +User Option: magit-pop-revision-stack-format + This option controls how the command ‘magit-pop-revision-stack’ + inserts a revision into the current buffer. + + The entries on the stack have the format ‘(HASH TOPLEVEL)’ and this + option has the format ‘(POINT-FORMAT EOB-FORMAT INDEX-REGEXP)’, all + of which may be nil or a string (though either one of EOB-FORMAT or + POINT-FORMAT should be a string, and if INDEX-REGEXP is non-nil, + then the two formats should be too). + + First INDEX-REGEXP is used to find the previously inserted entry, + by searching backward from point. The first submatch must match + the index number. That number is incremented by one, and becomes + the index number of the entry to be inserted. If you don’t want to + number the inserted revisions, then use nil for INDEX-REGEXP. + + If INDEX-REGEXP is non-nil then both POINT-FORMAT and EOB-FORMAT + should contain \"%N\", which is replaced with the number that was + determined in the previous step. + + Both formats, if non-nil and after removing %N, are then expanded + using ‘git show --format=FORMAT ...’ inside TOPLEVEL. + + The expansion of POINT-FORMAT is inserted at point, and the + expansion of EOB-FORMAT is inserted at the end of the buffer (if + the buffer ends with a comment, then it is inserted right before + that). + + +File: doc5khxAZ.info, Node: Commit Pseudo Headers, Next: Commit Mode and Hooks, Prev: Using the Revision Stack, Up: Editing Commit Messages + +Commit Pseudo Headers +..................... + +Some projects use pseudo headers in commit messages. Magit colorizes +such headers and provides some commands to insert such headers. + +User Option: git-commit-known-pseudo-headers + A list of Git pseudo headers to be highlighted. + +Key: C-c C-i (git-commit-insert-pseudo-header) + Insert a commit message pseudo header. + +Key: C-c C-a (git-commit-ack) + Insert a header acknowledging that you have looked at the commit. + +Key: C-c C-r (git-commit-review) + Insert a header acknowledging that you have reviewed the commit. + +Key: C-c C-s (git-commit-signoff) + Insert a header to sign off the commit. + +Key: C-c C-t (git-commit-test) + Insert a header acknowledging that you have tested the commit. + +Key: C-c C-o (git-commit-cc) + Insert a header mentioning someone who might be interested. + +Key: C-c C-p (git-commit-reported) + Insert a header mentioning the person who reported the issue being + fixed by the commit. + +Key: C-c M-i (git-commit-suggested) + Insert a header mentioning the person who suggested the change. + + +File: doc5khxAZ.info, Node: Commit Mode and Hooks, Next: Commit Message Conventions, Prev: Commit Pseudo Headers, Up: Editing Commit Messages + +Commit Mode and Hooks +..................... + +‘git-commit-mode’ is a minor mode that is only used to establish certain +key bindings. This makes it possible to use an arbitrary major mode in +buffers used to edit commit messages. It is even possible to use +different major modes in different repositories, which is useful when +different projects impose different commit message conventions. + +User Option: git-commit-major-mode + The value of this option is the major mode used to edit Git commit + messages. + + Because ‘git-commit-mode’ is a minor mode, we don’t use its mode hook +to setup the buffer, except for the key bindings. All other setup +happens in the function ‘git-commit-setup’, which among other things +runs the hook ‘git-commit-setup-hook’. + +User Option: git-commit-setup-hook + Hook run at the end of ‘git-commit-setup’. + +The following functions are suitable for this hook: + +Function: git-commit-save-message + Save the current buffer content to the commit message ring. + +Function: git-commit-setup-changelog-support + After this function is called, ChangeLog entries are treated as + paragraphs. + +Function: git-commit-turn-on-auto-fill + Turn on ‘auto-fill-mode’. + +Function: git-commit-turn-on-flyspell + Turn on Flyspell mode. Also prevent comments from being checked + and finally check current non-comment text. + +Function: git-commit-propertize-diff + Propertize the diff shown inside the commit message buffer. Git + inserts such diffs into the commit message template when the + ‘--verbose’ argument is used. ‘magit-commit’ by default does not + offer that argument because the diff that is shown in a separate + buffer is more useful. But some users disagree, which is why this + function exists. + +Function: bug-reference-mode + Hyperlink bug references in the buffer. + +Function: with-editor-usage-message + Show usage information in the echo area. + +User Option: git-commit-post-finish-hook + Hook run after the user finished writing a commit message. + + This hook is only run after pressing ‘C-c C-c’ in a buffer used to + edit a commit message. If a commit is created without the user + typing a message into a buffer, then this hook is not run. + + This hook is not run until the new commit has been created. If + doing so takes Git longer than one second, then this hook isn’t run + at all. For certain commands such as ‘magit-rebase-continue’ this + hook is never run because doing so would lead to a race condition. + + This hook is only run if ‘magit’ is available. + + Also see ‘magit-post-commit-hook’. + + +File: doc5khxAZ.info, Node: Commit Message Conventions, Prev: Commit Mode and Hooks, Up: Editing Commit Messages + +Commit Message Conventions +.......................... + +Git-Commit highlights certain violations of commonly accepted commit +message conventions. Certain violations even cause Git-Commit to ask +you to confirm that you really want to do that. This nagging can of +course be turned off, but the result of doing that usually is that +instead of some code it’s now the human who is reviewing your commits +who has to waste some time telling you to fix your commits. + +User Option: git-commit-summary-max-length + The intended maximal length of the summary line of commit messages. + Characters beyond this column are colorized to indicate that this + preference has been violated. + +User Option: git-commit-finish-query-functions + List of functions called to query before performing commit. + + The commit message buffer is current while the functions are + called. If any of them returns nil, then the commit is not + performed and the buffer is not killed. The user should then fix + the issue and try again. + + The functions are called with one argument. If it is non-nil then + that indicates that the user used a prefix argument to force + finishing the session despite issues. Functions should usually + honor this wish and return non-nil. + + By default the only member is ‘git-commit-check-style-conventions’. + +Function: git-commit-check-style-conventions + This function checks for violations of certain basic style + conventions. For each violation it asks users if they want to + proceed anyway. + +User Option: git-commit-style-convention-checks + This option controls what conventions the function by the same name + tries to enforce. The value is a list of self-explanatory symbols + identifying certain conventions; ‘non-empty-second-line’ and + ‘overlong-summary-line’. + + +File: doc5khxAZ.info, Node: Branching, Next: Merging, Prev: Committing, Up: Manipulating + +6.6 Branching +============= + +* Menu: + +* The Two Remotes:: +* Branch Commands:: +* Branch Git Variables:: +* Auxiliary Branch Commands:: + + +File: doc5khxAZ.info, Node: The Two Remotes, Next: Branch Commands, Up: Branching + +6.6.1 The Two Remotes +--------------------- + +The upstream branch of some local branch is the branch into which the +commits on that local branch should eventually be merged, usually +something like ‘origin/master’. For the ‘master’ branch itself the +upstream branch and the branch it is being pushed to, are usually the +same remote branch. But for a feature branch the upstream branch and +the branch it is being pushed to should differ. + + The commits on feature branches too should _eventually_ end up in a +remote branch such as ‘origin/master’ or ‘origin/maint’. Such a branch +should therefore be used as the upstream. But feature branches +shouldn’t be pushed directly to such branches. Instead a feature branch +‘my-feature’ is usually pushed to ‘my-fork/my-feature’ or if you are a +contributor ‘origin/my-feature’. After the new feature has been +reviewed, the maintainer merges the feature into ‘master’. And finally +‘master’ (not ‘my-feature’ itself) is pushed to ‘origin/master’. + + But new features seldom are perfect on the first try, and so feature +branches usually have to be reviewed, improved, and re-pushed several +times. Pushing should therefore be easy to do, and for that reason many +Git users have concluded that it is best to use the remote branch to +which the local feature branch is being pushed as its upstream. + + But luckily Git has long ago gained support for a push-remote which +can be configured separately from the upstream branch, using the +variables ‘branch..pushRemote’ and ‘remote.pushDefault’. So we no +longer have to choose which of the two remotes should be used as "the +remote". + + Each of the fetching, pulling, and pushing transient commands +features three suffix commands that act on the current branch and some +other branch. Of these, ‘p’ is bound to a command which acts on the +push-remote, ‘u’ is bound to a command which acts on the upstream, and +‘e’ is bound to a command which acts on any other branch. The status +buffer shows unpushed and unpulled commits for both the push-remote and +the upstream. + + It’s fairly simple to configure these two remotes. The values of all +the variables that are related to fetching, pulling, and pushing (as +well as some other branch-related variables) can be inspected and +changed using the command ‘magit-branch-configure’, which is available +from many transient prefix commands that deal with branches. It is also +possible to set the push-remote or upstream while pushing (see *note +Pushing::). + + +File: doc5khxAZ.info, Node: Branch Commands, Next: Branch Git Variables, Prev: The Two Remotes, Up: Branching + +6.6.2 Branch Commands +--------------------- + +The transient prefix command ‘magit-branch’ is used to create and +checkout branches, and to make changes to existing branches. It is not +used to fetch, pull, merge, rebase, or push branches, i.e., this command +deals with branches themselves, not with the commits reachable from +them. Those features are available from separate transient commands. + +Key: b (magit-branch) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + By default it also binds and displays the values of some + branch-related Git variables and allows changing their values. + +User Option: magit-branch-direct-configure + This option controls whether the transient command ‘magit-branch’ + can be used to directly change the values of Git variables. This + defaults to ‘t’ (to avoid changing key bindings). When set to + ‘nil’, then no variables are displayed by that transient command, + and its suffix command ‘magit-branch-configure’ has to be used + instead to view and change branch related variables. + +Key: b C (magit-branch-configure) + +Key: f C + +Key: F C + +Key: P C + This transient prefix command binds commands that set the value of + branch-related variables and displays them in a temporary buffer + until the transient is exited. + + With a prefix argument, this command always prompts for a branch. + + Without a prefix argument this depends on whether it was invoked as + a suffix of ‘magit-branch’ and on the + ‘magit-branch-direct-configure’ option. If ‘magit-branch’ already + displays the variables for the current branch, then it isn’t useful + to invoke another transient that displays them for the same branch. + In that case this command prompts for a branch. + + The variables are described in *note Branch Git Variables::. + +Key: b b (magit-checkout) + Checkout a revision read in the minibuffer and defaulting to the + branch or arbitrary revision at point. If the revision is a local + branch then that becomes the current branch. If it is something + else then ‘HEAD’ becomes detached. Checkout fails if the working + tree or the staging area contain changes. + +Key: b n (magit-branch-create) + Create a new branch. The user is asked for a branch or arbitrary + revision to use as the starting point of the new branch. When a + branch name is provided, then that becomes the upstream branch of + the new branch. The name of the new branch is also read in the + minibuffer. + + Also see option ‘magit-branch-prefer-remote-upstream’. + +Key: b c (magit-branch-and-checkout) + This command creates a new branch like ‘magit-branch-create’, but + then also checks it out. + + Also see option ‘magit-branch-prefer-remote-upstream’. + +Key: b l (magit-branch-checkout) + This command checks out an existing or new local branch. It reads + a branch name from the user offering all local branches and a + subset of remote branches as candidates. Remote branches for which + a local branch by the same name exists are omitted from the list of + candidates. The user can also enter a completely new branch name. + + • If the user selects an existing local branch, then that is + checked out. + + • If the user selects a remote branch, then it creates and + checks out a new local branch with the same name, and + configures the selected remote branch as the push target. + + • If the user enters a new branch name, then it creates and + checks that out, after also reading the starting-point from + the user. + + In the latter two cases the upstream is also set. Whether it is + set to the chosen starting point or something else depends on the + value of ‘magit-branch-adjust-remote-upstream-alist’. + +Key: b s (magit-branch-spinoff) + This command creates and checks out a new branch starting at and + tracking the current branch. That branch in turn is reset to the + last commit it shares with its upstream. If the current branch has + no upstream or no unpushed commits, then the new branch is created + anyway and the previously current branch is not touched. + + This is useful to create a feature branch after work has already + begun on the old branch (likely but not necessarily "master"). + + If the current branch is a member of the value of option + ‘magit-branch-prefer-remote-upstream’ (which see), then the current + branch will be used as the starting point as usual, but the + upstream of the starting-point may be used as the upstream of the + new branch, instead of the starting-point itself. + + If optional FROM is non-nil, then the source branch is reset to + ‘FROM~’, instead of to the last commit it shares with its upstream. + Interactively, FROM is only ever non-nil, if the region selects + some commits, and among those commits, FROM is the commit that is + the fewest commits ahead of the source branch. + + The commit at the other end of the selection actually does not + matter, all commits between FROM and ‘HEAD’ are moved to the new + branch. If FROM is not reachable from ‘HEAD’ or is reachable from + the source branch’s upstream, then an error is raised. + +Key: b S (magit-branch-spinout) + This command behaves like ‘magit-branch-spinoff’, except that it + does not change the current branch. If there are any uncommitted + changes, then it behaves exactly like ‘magit-branch-spinoff’. + +Key: b x (magit-branch-reset) + This command resets a branch, defaulting to the branch at point, to + the tip of another branch or any other commit. + + When the branch being reset is the current branch, then a hard + reset is performed. If there are any uncommitted changes, then the + user has to confirm the reset because those changes would be lost. + + This is useful when you have started work on a feature branch but + realize it’s all crap and want to start over. + + When resetting to another branch and a prefix argument is used, + then the target branch is set as the upstream of the branch that is + being reset. + +Key: b k (magit-branch-delete) + Delete one or multiple branches. If the region marks multiple + branches, then offer to delete those. Otherwise, prompt for a + single branch to be deleted, defaulting to the branch at point. + + Require confirmation when deleting branches is dangerous in some + way. Option ‘magit-no-confirm’ can be customized to not require + confirmation in certain cases. See its docstring to learn why + confirmation is required by default in certain cases or if a prompt + is confusing. + +Key: b m (magit-branch-rename) + Rename a branch. The branch and the new name are read in the + minibuffer. With prefix argument the branch is renamed even if + that name conflicts with an existing branch. + +User Option: magit-branch-read-upstream-first + When creating a branch, whether to read the upstream branch before + the name of the branch that is to be created. The default is ‘t’, + and I recommend you leave it at that. + +User Option: magit-branch-prefer-remote-upstream + This option specifies whether remote upstreams are favored over + local upstreams when creating new branches. + + When a new branch is created, then the branch, commit, or stash at + point is suggested as the starting point of the new branch, or if + there is no such revision at point the current branch. In either + case the user may choose another starting point. + + If the chosen starting point is a branch, then it may also be set + as the upstream of the new branch, depending on the value of the + Git variable ‘branch.autoSetupMerge’. By default this is done for + remote branches, but not for local branches. + + You might prefer to always use some remote branch as upstream. If + the chosen starting point is (1) a local branch, (2) whose name + matches a member of the value of this option, (3) the upstream of + that local branch is a remote branch with the same name, and (4) + that remote branch can be fast-forwarded to the local branch, then + the chosen branch is used as starting point, but its own upstream + is used as the upstream of the new branch. + + Members of this option’s value are treated as branch names that + have to match exactly unless they contain a character that makes + them invalid as a branch name. Recommended characters to use to + trigger interpretation as a regexp are "*" and "^". Some other + characters which you might expect to be invalid, actually are not, + e.g., ".+$" are all perfectly valid. More precisely, if ‘git + check-ref-format --branch STRING’ exits with a non-zero status, + then treat STRING as a regexp. + + Assuming the chosen branch matches these conditions you would end + up with with e.g.: + + feature --upstream--> origin/master + + instead of + + feature --upstream--> master --upstream--> origin/master + + Which you prefer is a matter of personal preference. If you do + prefer the former, then you should add branches such as ‘master’, + ‘next’, and ‘maint’ to the value of this options. + +User Option: magit-branch-adjust-remote-upstream-alist + The value of this option is an alist of branches to be used as the + upstream when branching a remote branch. + + When creating a local branch from an ephemeral branch located on a + remote, e.g., a feature or hotfix branch, then that remote branch + should usually not be used as the upstream branch, since the + push-remote already allows accessing it and having both the + upstream and the push-remote reference the same related branch + would be wasteful. Instead a branch like "maint" or "master" + should be used as the upstream. + + This option allows specifying the branch that should be used as the + upstream when branching certain remote branches. The value is an + alist of the form ‘((UPSTREAM . RULE)...)’. The first matching + element is used, the following elements are ignored. + + UPSTREAM is the branch to be used as the upstream for branches + specified by RULE. It can be a local or a remote branch. + + RULE can either be a regular expression, matching branches whose + upstream should be the one specified by UPSTREAM. Or it can be a + list of the only branches that should *not* use UPSTREAM; all other + branches will. Matching is done after stripping the remote part of + the name of the branch that is being branched from. + + If you use a finite set of non-ephemeral branches across all your + repositories, then you might use something like: + + (("origin/master" . ("master" "next" "maint"))) + + Or if the names of all your ephemeral branches contain a slash, at + least in some repositories, then a good value could be: + + (("origin/master" . "/")) + + Of course you can also fine-tune: + + (("origin/maint" . "\\`hotfix/") + ("origin/master" . "\\`feature/")) + + UPSTREAM can be a local branch: + + (("master" . ("master" "next" "maint"))) + + Because the main branch is no longer almost always named "master" you +should also account for other common names: + + (("main" . ("main" "master" "next" "maint")) + ("master" . ("main" "master" "next" "maint"))) + +Command: magit-branch-orphan + This command creates and checks out a new orphan branch with + contents from a given revision. + +Command: magit-branch-or-checkout + This command is a hybrid between ‘magit-checkout’ and + ‘magit-branch-and-checkout’ and is intended as a replacement for + the former in ‘magit-branch’. + + It first asks the user for an existing branch or revision. If the + user input actually can be resolved as a branch or revision, then + it checks that out, just like ‘magit-checkout’ would. + + Otherwise it creates and checks out a new branch using the input as + its name. Before doing so it reads the starting-point for the new + branch. This is similar to what ‘magit-branch-and-checkout’ does. + + To use this command instead of ‘magit-checkout’ add this to your + init file: + + (transient-replace-suffix 'magit-branch 'magit-checkout + '("b" "dwim" magit-branch-or-checkout)) + + +File: doc5khxAZ.info, Node: Branch Git Variables, Next: Auxiliary Branch Commands, Prev: Branch Commands, Up: Branching + +6.6.3 Branch Git Variables +-------------------------- + +These variables can be set from the transient prefix command +‘magit-branch-configure’. By default they can also be set from +‘magit-branch’. See *note Branch Commands::. + +Variable: branch.NAME.merge + Together with ‘branch.NAME.remote’ this variable defines the + upstream branch of the local branch named NAME. The value of this + variable is the full reference of the upstream _branch_. + +Variable: branch.NAME.remote + Together with ‘branch.NAME.merge’ this variable defines the + upstream branch of the local branch named NAME. The value of this + variable is the name of the upstream _remote_. + +Variable: branch.NAME.rebase + This variable controls whether pulling into the branch named NAME + is done by rebasing or by merging the fetched branch. + + • When ‘true’ then pulling is done by rebasing. + • When ‘false’ then pulling is done by merging. + • When undefined then the value of ‘pull.rebase’ is used. The + default of that variable is ‘false’. + +Variable: branch.NAME.pushRemote + This variable specifies the remote that the branch named NAME is + usually pushed to. The value has to be the name of an existing + remote. + + It is not possible to specify the name of _branch_ to push the + local branch to. The name of the remote branch is always the same + as the name of the local branch. + + If this variable is undefined but ‘remote.pushDefault’ is defined, + then the value of the latter is used. By default + ‘remote.pushDefault’ is undefined. + +Variable: branch.NAME.description + This variable can be used to describe the branch named NAME. That + description is used, e.g., when turning the branch into a series of + patches. + + The following variables specify defaults which are used if the above +branch-specific variables are not set. + +Variable: pull.rebase + This variable specifies whether pulling is done by rebasing or by + merging. It can be overwritten using ‘branch.NAME.rebase’. + + • When ‘true’ then pulling is done by rebasing. + • When ‘false’ (the default) then pulling is done by merging. + + Since it is never a good idea to merge the upstream branch into a + feature or hotfix branch and most branches are such branches, you + should consider setting this to ‘true’, and ‘branch.master.rebase’ + to ‘false’. + +Variable: remote.pushDefault + This variable specifies what remote the local branches are usually + pushed to. This can be overwritten per branch using + ‘branch.NAME.pushRemote’. + + The following variables are used during the creation of a branch and +control whether the various branch-specific variables are automatically +set at this time. + +Variable: branch.autoSetupMerge + This variable specifies under what circumstances creating a branch + NAME should result in the variables ‘branch.NAME.merge’ and + ‘branch.NAME.remote’ being set according to the starting point used + to create the branch. If the starting point isn’t a branch, then + these variables are never set. + + • When ‘always’ then the variables are set regardless of whether + the starting point is a local or a remote branch. + • When ‘true’ (the default) then the variables are set when the + starting point is a remote branch, but not when it is a local + branch. + • When ‘false’ then the variables are never set. + +Variable: branch.autoSetupRebase + This variable specifies whether creating a branch NAME should + result in the variable ‘branch.NAME.rebase’ being set to ‘true’. + + • When ‘always’ then the variable is set regardless of whether + the starting point is a local or a remote branch. + • When ‘local’ then the variable are set when the starting point + is a local branch, but not when it is a remote branch. + • When ‘remote’ then the variable are set when the starting + point is a remote branch, but not when it is a local branch. + • When ‘never’ (the default) then the variable is never set. + + Note that the respective commands always change the repository-local +values. If you want to change the global value, which is used when the +local value is undefined, then you have to do so on the command line, +e.g.: + + git config --global remote.autoSetupMerge always + + For more information about these variables you should also see +man:git-config Also see [BROKEN LINK: man:git-branch], [BROKEN LINK: +man:git-checkout] and *note Pushing::. + +User Option: magit-prefer-remote-upstream + This option controls whether commands that read a branch from the + user and then set it as the upstream branch, offer a local or a + remote branch as default completion candidate, when they have the + choice. + + This affects all commands that use ‘magit-read-upstream-branch’ or + ‘magit-read-starting-point’, which includes all commands that + change the upstream and many which create new branches. + + +File: doc5khxAZ.info, Node: Auxiliary Branch Commands, Prev: Branch Git Variables, Up: Branching + +6.6.4 Auxiliary Branch Commands +------------------------------- + +These commands are not available from the transient ‘magit-branch’ by +default. + +Command: magit-branch-shelve + This command shelves a branch. This is done by deleting the + branch, and creating a new reference "refs/shelved/BRANCH-NAME" + pointing at the same commit as the branch pointed at. If the + deleted branch had a reflog, then that is preserved as the reflog + of the new reference. + + This is useful if you want to move a branch out of sight, but are + not ready to completely discard it yet. + +Command: magit-branch-unshelve + This command unshelves a branch that was previously shelved using + ‘magit-branch-shelve’. This is done by deleting the reference + "refs/shelved/BRANCH-NAME" and creating a branch "BRANCH-NAME" + pointing at the same commit as the deleted reference pointed at. + If the deleted reference had a reflog, then that is restored as the + reflog of the branch. + + +File: doc5khxAZ.info, Node: Merging, Next: Resolving Conflicts, Prev: Branching, Up: Manipulating + +6.7 Merging +=========== + +Also see [BROKEN LINK: man:git-merge] For information on how to resolve +merge conflicts see the next section. + +Key: m (magit-merge) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no merge is in progress, then the transient features the +following suffix commands. + +Key: m m (magit-merge-plain) + This command merges another branch or an arbitrary revision into + the current branch. The branch or revision to be merged is read in + the minibuffer and defaults to the branch at point. + + Unless there are conflicts or a prefix argument is used, then the + resulting merge commit uses a generic commit message, and the user + does not get a chance to inspect or change it before the commit is + created. With a prefix argument this does not actually create the + merge commit, which makes it possible to inspect how conflicts were + resolved and to adjust the commit message. + +Key: m e (magit-merge-editmsg) + This command merges another branch or an arbitrary revision into + the current branch and opens a commit message buffer, so that the + user can make adjustments. The commit is not actually created + until the user finishes with ‘C-c C-c’. + +Key: m n (magit-merge-nocommit) + This command merges another branch or an arbitrary revision into + the current branch, but does not actually create the merge commit. + The user can then further adjust the merge, even when automatic + conflict resolution succeeded and/or adjust the commit message. + +Key: m a (magit-merge-absorb) + This command merges another local branch into the current branch + and then removes the former. + + Before the source branch is merged, it is first force pushed to its + push-remote, provided the respective remote branch already exists. + This ensures that the respective pull-request (if any) won’t get + stuck on some obsolete version of the commits that are being + merged. Finally, if ‘magit-branch-pull-request’ was used to create + the merged branch, then the respective remote branch is also + removed. + +Key: m d (magit-merge-dissolve) + This command merges the current branch into another local branch + and then removes the former. The latter becomes the new current + branch. + + Before the source branch is merged, it is first force pushed to its + push-remote, provided the respective remote branch already exists. + This ensures that the respective pull-request (if any) won’t get + stuck on some obsolete version of the commits that are being + merged. Finally, if ‘magit-branch-pull-request’ was used to create + the merged branch, then the respective remote branch is also + removed. + +Key: m s (magit-merge-squash) + This command squashes the changes introduced by another branch or + an arbitrary revision into the current branch. This only applies + the changes made by the squashed commits. No information is + preserved that would allow creating an actual merge commit. + Instead of this command you should probably use a command from the + apply transient. + +Key: m p (magit-merge-preview) + This command shows a preview of merging another branch or an + arbitrary revision into the current branch. + + Note that commands, that normally change how a diff is displayed, + do not work in buffers created by this command, because the + underlying Git command does not support diff arguments. + + When a merge is in progress, then the transient instead features the +following suffix commands. + +Key: m m (magit-merge) + After the user resolved conflicts, this command proceeds with the + merge. If some conflicts weren’t resolved, then this command + fails. + +Key: m a (magit-merge-abort) + This command aborts the current merge operation. + + +File: doc5khxAZ.info, Node: Resolving Conflicts, Next: Rebasing, Prev: Merging, Up: Manipulating + +6.8 Resolving Conflicts +======================= + +When merging branches (or otherwise combining or changing history) +conflicts can occur. If you edited two completely different parts of +the same file in two branches and then merge one of these branches into +the other, then Git can resolve that on its own, but if you edit the +same area of a file, then a human is required to decide how the two +versions, or "sides of the conflict", are to be combined into one. + + Here we can only provide a brief introduction to the subject and +point you toward some tools that can help. If you are new to this, then +please also consult Git’s own documentation as well as other resources. + + If a file has conflicts and Git cannot resolve them by itself, then +it puts both versions into the affected file along with special markers +whose purpose is to denote the boundaries of the unresolved part of the +file and between the different versions. These boundary lines begin +with the strings consisting of seven times the same character, one of +‘<’, ‘|’, ‘=’ and ‘>’, and are followed by information about the source +of the respective versions, e.g.: + + <<<<<<< HEAD + Take the blue pill. + ======= + Take the red pill. + >>>>>>> feature + + In this case you have chosen to take the red pill on one branch and +on another you picked the blue pill. Now that you are merging these two +diverging branches, Git cannot possibly know which pill you want to +take. + + To resolve that conflict you have to create a version of the affected +area of the file by keeping only one of the sides, possibly by editing +it in order to bring in the changes from the other side, remove the +other versions as well as the markers, and then stage the result. A +possible resolution might be: + + Take both pills. + + Often it is useful to see not only the two sides of the conflict but +also the "original" version from before the same area of the file was +modified twice on different branches. Instruct Git to insert that +version as well by running this command once: + + git config --global merge.conflictStyle diff3 + + The above conflict might then have looked like this: + + <<<<<<< HEAD + Take the blue pill. + ||||||| merged common ancestors + Take either the blue or the red pill, but not both. + ======= + Take the red pill. + >>>>>>> feature + + If that were the case, then the above conflict resolution would not +have been correct, which demonstrates why seeing the original version +alongside the conflicting versions can be useful. + + You can perform the conflict resolution completely by hand, but Emacs +also provides some packages that help in the process: Smerge, Ediff +(*note (ediff)Top::), and Emerge (*note (emacs)Emerge::). Magit does +not provide its own tools for conflict resolution, but it does make +using Smerge and Ediff more convenient. (Ediff supersedes Emerge, so +you probably don’t want to use the latter anyway.) + + In the Magit status buffer, files with unresolved conflicts are +listed in the "Unstaged changes" and/or "Staged changes" sections. They +are prefixed with the word "unmerged", which in this context essentially +is a synonym for "unresolved". + + Pressing ‘RET’ while point is on such a file section shows a buffer +visiting that file, turns on ‘smerge-mode’ in that buffer, and places +point inside the first area with conflicts. You should then resolve +that conflict using regular edit commands and/or Smerge commands. + + Unfortunately Smerge does not have a manual, but you can get a list +of commands and binding ‘C-c ^ C-h’ and press ‘RET’ while point is on a +command name to read its documentation. + + Normally you would edit one version and then tell Smerge to keep only +that version. Use ‘C-c ^ m’ (‘smerge-keep-mine’) to keep the ‘HEAD’ +version or ‘C-c ^ o’ (‘smerge-keep-other’) to keep the version that +follows "|||||||". Then use ‘C-c ^ n’ to move to the next conflicting +area in the same file. Once you are done resolving conflicts, return to +the Magit status buffer. The file should now be shown as "modified", no +longer as "unmerged", because Smerge automatically stages the file when +you save the buffer after resolving the last conflict. + + Magit now wraps the mentioned Smerge commands, allowing you to use +these key bindings without having to go to the file-visiting buffer. +Additionally ‘k’ (‘magit-discard’) on a hunk with unresolved conflicts +asks which side to keep or, if point is on a side, then it keeps it +without prompting. Similarly ‘k’ on a unresolved file ask which side to +keep. + + Alternatively you could use Ediff, which uses separate buffers for +the different versions of the file. To resolve conflicts in a file +using Ediff press ‘e’ while point is on such a file in the status +buffer. + + Ediff can be used for other purposes as well. For more information +on how to enter Ediff from Magit, see *note Ediffing::. Explaining how +to use Ediff is beyond the scope of this manual, instead see *note +(ediff)Top::. + + If you are unsure whether you should Smerge or Ediff, then use the +former. It is much easier to understand and use, and except for truly +complex conflicts, the latter is usually overkill. + + +File: doc5khxAZ.info, Node: Rebasing, Next: Cherry Picking, Prev: Resolving Conflicts, Up: Manipulating + +6.9 Rebasing +============ + +Also see [BROKEN LINK: man:git-rebase] For information on how to resolve +conflicts that occur during rebases see the preceding section. + +Key: r (magit-rebase) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no rebase is in progress, then the transient features the +following suffix commands. + + Using one of these commands _starts_ a rebase sequence. Git might +then stop somewhere along the way, either because you told it to do so, +or because applying a commit failed due to a conflict. When that +happens, then the status buffer shows information about the rebase +sequence which is in progress in a section similar to a log section. +See *note Information About In-Progress Rebase::. + + For information about the upstream and the push-remote, see *note The +Two Remotes::. + +Key: r p (magit-rebase-onto-pushremote) + This command rebases the current branch onto its push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +Key: r u (magit-rebase-onto-upstream) + This command rebases the current branch onto its upstream branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +Key: r e (magit-rebase-branch) + This command rebases the current branch onto a branch read in the + minibuffer. All commits that are reachable from head but not from + the selected branch TARGET are being rebased. + +Key: r s (magit-rebase-subset) + This command starts a non-interactive rebase sequence to transfer + commits from START to ‘HEAD’ onto NEWBASE. START has to be + selected from a list of recent commits. + + By default Magit uses the ‘--autostash’ argument, which causes +uncommitted changes to be stored in a stash before the rebase begins. +These changes are restored after the rebase completes and if possible +the stash is removed. If the stash does not apply cleanly, then the +stash is not removed. In case something goes wrong when resolving the +conflicts, this allows you to start over. + + Even though one of the actions is dedicated to interactive rebases, +the transient also features the infix argument ‘--interactive’. This +can be used to turn one of the other, non-interactive rebase variants +into an interactive rebase. + + For example if you want to clean up a feature branch and at the same +time rebase it onto ‘master’, then you could use ‘r-iu’. But we +recommend that you instead do that in two steps. First use ‘ri’ to +cleanup the feature branch, and then in a second step ‘ru’ to rebase it +onto ‘master’. That way if things turn out to be more complicated than +you thought and/or you make a mistake and have to start over, then you +only have to redo half the work. + + Explicitly enabling ‘--interactive’ won’t have an effect on the +following commands as they always use that argument anyway, even if it +is not enabled in the transient. + +Key: r i (magit-rebase-interactive) + This command starts an interactive rebase sequence. + +Key: r f (magit-rebase-autosquash) + This command combines squash and fixup commits with their intended + targets. + + By default only commits that are not reachable from the upstream + branch are potentially squashed into. If no upstream is configured + or with a prefix argument, the user is prompted for the first + commit to potentially squash into. + +Key: r m (magit-rebase-edit-commit) + This command starts an interactive rebase sequence that lets the + user edit a single older commit. + +Key: r w (magit-rebase-reword-commit) + This command starts an interactive rebase sequence that lets the + user reword a single older commit. + +Key: r k (magit-rebase-remove-commit) + This command removes a single older commit using rebase. + + When a rebase is in progress, then the transient instead features the +following suffix commands. + +Key: r r (magit-rebase-continue) + This command restart the current rebasing operation. + + In some cases this pops up a commit message buffer for you do edit. + With a prefix argument the old message is reused as-is. + +Key: r s (magit-rebase-skip) + This command skips the current commit and restarts the current + rebase operation. + +Key: r e (magit-rebase-edit) + This command lets the user edit the todo list of the current rebase + operation. + +Key: r a (magit-rebase-abort) + This command aborts the current rebase operation, restoring the + original branch. + +* Menu: + +* Editing Rebase Sequences:: +* Information About In-Progress Rebase:: + + +File: doc5khxAZ.info, Node: Editing Rebase Sequences, Next: Information About In-Progress Rebase, Up: Rebasing + +6.9.1 Editing Rebase Sequences +------------------------------ + +Key: C-c C-c (with-editor-finish) + Finish the current editing session by returning with exit code 0. + Git then uses the rebase instructions it finds in the file. + +Key: C-c C-k (with-editor-cancel) + Cancel the current editing session by returning with exit code 1. + Git then forgoes starting the rebase sequence. + +Key: RET (git-rebase-show-commit) + Show the commit on the current line in another buffer and select + that buffer. + +Key: SPC (git-rebase-show-or-scroll-up) + Show the commit on the current line in another buffer without + selecting that buffer. If the revision buffer is already visible + in another window of the current frame, then instead scroll that + window up. + +Key: DEL (git-rebase-show-or-scroll-down) + Show the commit on the current line in another buffer without + selecting that buffer. If the revision buffer is already visible + in another window of the current frame, then instead scroll that + window down. + +Key: p (git-rebase-backward-line) + Move to previous line. + +Key: n (forward-line) + Move to next line. + +Key: M-p (git-rebase-move-line-up) + Move the current commit (or command) up. + +Key: M-n (git-rebase-move-line-down) + Move the current commit (or command) down. + +Key: r (git-rebase-reword) + Edit message of commit on current line. + +Key: e (git-rebase-edit) + Stop at the commit on the current line. + +Key: s (git-rebase-squash) + This command folds the commit on the current line into the previous + commit, giving the user a change to manually merge the two + messages. + +Key: S (git-rebase-squish) + This command folds the commit on the current line into the previous + commit, discarding the message of the previous commit but giving + the user a change to edit the final message, based on the message + of the current commit. + + This action’s indicator, shown in the list of commits, is ‘fixup + -c’ (with a lower-case c). + +Key: f (git-rebase-fixup) + This command folds the commit on the current line into the previous + commit, using only the message of the previous commit as-is and + discarding the message of the current commit. + +Key: F (git-rebase-alter) + This command folds the commit on the current into the previous + commit, discarding the message of the previous commit and instead + using the message of the current commit as-is. + + This is like ‘git-rebase-alter’, except that it uses the other + message. This is also like ‘git-rebase-squish’, except that it + lets the user edit the message. + + This action’s indicator, shown in the list of commits, is ‘fixup + -C’ (with a upper-case C). + +Key: k (git-rebase-kill-line) + Comment the current action line, or if it is already commented, + then uncomment it. + +Key: c (git-rebase-pick) + Use commit on current line. + +Key: x (git-rebase-exec) + Insert a shell command to be run after the proceeding commit. + + If there already is such a command on the current line, then edit + that instead. With a prefix argument insert a new command even + when there already is one on the current line. With empty input + remove the command on the current line, if any. + +Key: b (git-rebase-break) + Insert a break action before the current line, instructing Git to + return control to the user. + +Key: y (git-rebase-insert) + Read an arbitrary commit and insert it below current line. + +Key: C-x u (git-rebase-undo) + Undo some previous changes. Like ‘undo’ but works in read-only + buffers. + +User Option: git-rebase-auto-advance + Whether to move to next line after changing a line. + +User Option: git-rebase-show-instructions + Whether to show usage instructions inside the rebase buffer. + +User Option: git-rebase-confirm-cancel + Whether confirmation is required to cancel. + + When a rebase is performed with the ‘--rebase-merges’ option, the +sequence will include a few other types of actions and the following +commands become relevant. + +Key: l (git-rebase-label) + This commands inserts a label action or edits the one at point. + +Key: t (git-rebase-reset) + This command inserts a reset action or edits the one at point. The + prompt will offer the labels that are currently present in the + buffer. + +Key: MM (git-rebase-merge) + The command inserts a merge action or edits the one at point. The + prompt will offer the labels that are currently present in the + buffer. Specifying a message to reuse via ‘-c’ or ‘-C’ is not + supported; an editor will always be invoked for the merge. + +Key: Mt (git-rebase-merge-toggle-editmsg) + This command toggles between the ‘-C’ and ‘-c’ options of the merge + action at point. These options both specify a commit whose message + should be reused. The lower-case variant instructs Git to invoke + the editor when creating the merge, allowing the user to edit the + message. + + +File: doc5khxAZ.info, Node: Information About In-Progress Rebase, Prev: Editing Rebase Sequences, Up: Rebasing + +6.9.2 Information About In-Progress Rebase +------------------------------------------ + +While a rebase sequence is in progress, the status buffer features a +section that lists the commits that have already been applied as well as +the commits that still have to be applied. + + The commits are split in two halves. When rebase stops at a commit, +either because the user has to deal with a conflict or because s/he +explicitly requested that rebase stops at that commit, then point is +placed on the commit that separates the two groups, i.e., on ‘HEAD’. +The commits above it have not been applied yet, while the ‘HEAD’ and the +commits below it have already been applied. In between these two groups +of applied and yet-to-be applied commits, there sometimes is a commit +which has been dropped. + + Each commit is prefixed with a word and these words are additionally +shown in different colors to indicate the status of the commits. + + The following colors are used: + + • Commits that use the same foreground color as the ‘default’ face + have not been applied yet. + + • Yellow commits have some special relationship to the commit rebase + stopped at. This is used for the words "join", "goal", "same" and + "work" (see below). + + • Gray commits have already been applied. + + • The blue commit is the ‘HEAD’ commit. + + • The green commit is the commit the rebase sequence stopped at. If + this is the same commit as ‘HEAD’ (e.g., because you haven’t done + anything yet after rebase stopped at the commit, then this commit + is shown in blue, not green). There can only be a green *and* a + blue commit at the same time, if you create one or more new commits + after rebase stops at a commit. + + • Red commits have been dropped. They are shown for reference only, + e.g., to make it easier to diff. + + Of course these colors are subject to the color-theme in use. + + The following words are used: + + • Commits prefixed with ‘pick’, ‘reword’, ‘edit’, ‘squash’, and + ‘fixup’ have not been applied yet. These words have the same + meaning here as they do in the buffer used to edit the rebase + sequence. See *note Editing Rebase Sequences::. When the + ‘--rebase-merges’ option was specified, ‘reset’, ‘label’, and + ‘merge’ lines may also be present. + + • Commits prefixed with ‘done’ and ‘onto’ have already been applied. + It is possible for such a commit to be the ‘HEAD’, in which case it + is blue. Otherwise it is grey. + + • The commit prefixed with ‘onto’ is the commit on top of which + all the other commits are being re-applied. This commit + itself did not have to be re-applied, it is the commit rebase + did rewind to before starting to re-apply other commits. + + • Commits prefixed with ‘done’ have already been re-applied. + This includes commits that have been re-applied but also new + commits that you have created during the rebase. + + • All other commits, those not prefixed with any of the above words, + are in some way related to the commit at which rebase stopped. + + To determine whether a commit is related to the stopped-at commit + their hashes, trees and patch-ids (1) are being compared. The + commit message is not used for this purpose. + + Generally speaking commits that are related to the stopped-at + commit can have any of the used colors, though not all color/word + combinations are possible. + + Words used for stopped-at commits are: + + • When a commit is prefixed with ‘void’, then that indicates + that Magit knows for sure that all the changes in that commit + have been applied using several new commits. This commit is + no longer reachable from ‘HEAD’, and it also isn’t one of the + commits that will be applied when resuming the session. + + • When a commit is prefixed with ‘join’, then that indicates + that the rebase sequence stopped at that commit due to a + conflict - you now have to join (merge) the changes with what + has already been applied. In a sense this is the commit + rebase stopped at, but while its effect is already in the + index and in the worktree (with conflict markers), the commit + itself has not actually been applied yet (it isn’t the + ‘HEAD’). So it is shown in yellow, like the other commits + that still have to be applied. + + • When a commit is prefixed with ‘stop’ or a _blue_ or _green_ + ‘same’, then that indicates that rebase stopped at this + commit, that it is still applied or has been applied again, + and that at least its patch-id is unchanged. + + • When a commit is prefixed with ‘stop’, then that + indicates that rebase stopped at that commit because you + requested that earlier, and its patch-id is unchanged. + It might even still be the exact same commit. + + • When a commit is prefixed with a _blue_ or _green_ + ‘same’, then that indicates that while its tree or hash + changed, its patch-id did not. If it is blue, then it is + the ‘HEAD’ commit (as always for blue). When it is + green, then it no longer is ‘HEAD’ because other commit + have been created since (but before continuing the + rebase). + + • When a commit is prefixed with ‘goal’, a _yellow_ ‘same,’ or + ‘work’, then that indicates that rebase applied that commit + but that you then reset ‘HEAD’ to an earlier commit (likely to + split it up into multiple commits), and that there are some + uncommitted changes remaining which likely (but not + necessarily) originate from that commit. + + • When a commit is prefixed with ‘goal’, then that + indicates that it is still possible to create a new + commit with the exact same tree (the "goal") without + manually editing any files, by committing the index, or + by staging all changes and then committing that. This is + the case when the original tree still exists in the index + or worktree in untainted form. + + • When a commit is prefixed with a yellow ‘same’, then that + indicates that it is no longer possible to create a + commit with the exact same tree, but that it is still + possible to create a commit with the same patch-id. This + would be the case if you created a new commit with other + changes, but the changes from the original commit still + exist in the index or working tree in untainted form. + + • When a commit is prefixed with ‘work’, then that + indicates that you reset ‘HEAD’ to an earlier commit, and + that there are some staged and/or unstaged changes + (likely, but not necessarily) originating from that + commit. However it is no longer possible to create a new + commit with the same tree or at least the same patch-id + because you have already made other changes. + + • When a commit is prefixed with ‘poof’ or ‘gone’, then that + indicates that rebase applied that commit but that you then + reset ‘HEAD’ to an earlier commit (likely to split it up into + multiple commits), and that there are no uncommitted changes. + + • When a commit is prefixed with ‘poof’, then that + indicates that it is no longer reachable from ‘HEAD’, but + that it has been replaced with one or more commits, which + together have the exact same effect. + + • When a commit is prefixed with ‘gone’, then that + indicates that it is no longer reachable from ‘HEAD’ and + that we also cannot determine whether its changes are + still in effect in one or more new commits. They might + be, but if so, then there must also be other changes + which makes it impossible to know for sure. + + Do not worry if you do not fully understand the above. That’s okay, +you will acquire a good enough understanding through practice. + + For other sequence operations such as cherry-picking, a similar +section is displayed, but they lack some of the features described +above, due to limitations in the git commands used to implement them. +Most importantly these sequences only support "picking" a commit but not +other actions such as "rewording", and they do not keep track of the +commits which have already been applied. + + ---------- Footnotes ---------- + + (1) The patch-id is a hash of the _changes_ introduced by a commit. +It differs from the hash of the commit itself, which is a hash of the +result of applying that change (i.e., the resulting trees and blobs) as +well as author and committer information, the commit message, and the +hashes of the parents of the commit. The patch-id hash on the other +hand is created only from the added and removed lines, even line numbers +and whitespace changes are ignored when calculating this hash. The +patch-ids of two commits can be used to answer the question "Do these +commits make the same change?". + + +File: doc5khxAZ.info, Node: Cherry Picking, Next: Resetting, Prev: Rebasing, Up: Manipulating + +6.10 Cherry Picking +=================== + +Also see [BROKEN LINK: man:git-cherry-pick] + +Key: A (magit-cherry-pick) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no cherry-pick or revert is in progress, then the transient +features the following suffix commands. + +Key: A A (magit-cherry-copy) + This command copies COMMITS from another branch onto the current + branch. If the region selects multiple commits, then those are + copied, without prompting. Otherwise the user is prompted for a + commit or range, defaulting to the commit at point. + +Key: A a (magit-cherry-apply) + This command applies the changes in COMMITS from another branch + onto the current branch. If the region selects multiple commits, + then those are used, without prompting. Otherwise the user is + prompted for a commit or range, defaulting to the commit at point. + + This command also has a top-level binding, which can be invoked + without using the transient by typing ‘a’ at the top-level. + + The following commands not only apply some commits to some branch, +but also remove them from some other branch. The removal is performed +using either ‘git-update-ref’ or if necessary ‘git-rebase’. Both +applying commits as well as removing them using ‘git-rebase’ can lead to +conflicts. If that happens, then these commands abort and you not only +have to resolve the conflicts but also finish the process the same way +you would have to if these commands didn’t exist at all. + +Key: A h (magit-cherry-harvest) + This command moves the selected COMMITS that must be located on + another BRANCH onto the current branch instead, removing them from + the former. When this command succeeds, then the same branch is + current as before. + + Applying the commits on the current branch or removing them from + the other branch can lead to conflicts. When that happens, then + this command stops and you have to resolve the conflicts and then + finish the process manually. + +Key: A d (magit-cherry-donate) + This command moves the selected COMMITS from the current branch + onto another existing BRANCH, removing them from the former. When + this command succeeds, then the same branch is current as before. + ‘HEAD’ is allowed to be detached initially. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + +Key: A n (magit-cherry-spinout) + This command moves the selected COMMITS from the current branch + onto a new branch BRANCH, removing them from the former. When this + command succeeds, then the same branch is current as before. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + +Key: A s (magit-cherry-spinoff) + This command moves the selected COMMITS from the current branch + onto a new branch BRANCH, removing them from the former. When this + command succeeds, then the new branch is checked out. + + Applying the commits on the other branch or removing them from the + current branch can lead to conflicts. When that happens, then this + command stops and you have to resolve the conflicts and then finish + the process manually. + + When a cherry-pick or revert is in progress, then the transient +instead features the following suffix commands. + +Key: A A (magit-sequence-continue) + Resume the current cherry-pick or revert sequence. + +Key: A s (magit-sequence-skip) + Skip the stopped at commit during a cherry-pick or revert sequence. + +Key: A a (magit-sequence-abort) + Abort the current cherry-pick or revert sequence. This discards + all changes made since the sequence started. + +* Menu: + +* Reverting:: + + +File: doc5khxAZ.info, Node: Reverting, Up: Cherry Picking + +6.10.1 Reverting +---------------- + +Key: V (magit-revert) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + When no cherry-pick or revert is in progress, then the transient +features the following suffix commands. + +Key: V V (magit-revert-and-commit) + Revert a commit by creating a new commit. Prompt for a commit, + defaulting to the commit at point. If the region selects multiple + commits, then revert all of them, without prompting. + +Key: V v (magit-revert-no-commit) + Revert a commit by applying it in reverse to the working tree. + Prompt for a commit, defaulting to the commit at point. If the + region selects multiple commits, then revert all of them, without + prompting. + + When a cherry-pick or revert is in progress, then the transient +instead features the following suffix commands. + +Key: V V (magit-sequence-continue) + Resume the current cherry-pick or revert sequence. + +Key: V s (magit-sequence-skip) + Skip the stopped at commit during a cherry-pick or revert sequence. + +Key: V a (magit-sequence-abort) + Abort the current cherry-pick or revert sequence. This discards + all changes made since the sequence started. + + +File: doc5khxAZ.info, Node: Resetting, Next: Stashing, Prev: Cherry Picking, Up: Manipulating + +6.11 Resetting +============== + +Also see [BROKEN LINK: man:git-reset] + +Key: x (magit-reset-quickly) + Reset the ‘HEAD’ and index to some commit read from the user and + defaulting to the commit at point, and possibly also reset the + working tree. With a prefix argument reset the working tree + otherwise don’t. + +Key: X m (magit-reset-mixed) + Reset the ‘HEAD’ and index to some commit read from the user and + defaulting to the commit at point. The working tree is kept as-is. + +Key: X s (magit-reset-soft) + Reset the ‘HEAD’ to some commit read from the user and defaulting + to the commit at point. The index and the working tree are kept + as-is. + +Key: X h (magit-reset-hard) + Reset the ‘HEAD’, index, and working tree to some commit read from + the user and defaulting to the commit at point. + +Key: X k (magit-reset-keep) + Reset the ‘HEAD’, index, and working tree to some commit read from + the user and defaulting to the commit at point. Uncommitted + changes are kept as-is. + +Key: X i (magit-reset-index) + Reset the index to some commit read from the user and defaulting to + the commit at point. Keep the ‘HEAD’ and working tree as-is, so if + the commit refers to the ‘HEAD’, then this effectively unstages all + changes. + +Key: X w (magit-reset-worktree) + Reset the working tree to some commit read from the user and + defaulting to the commit at point. Keep the ‘HEAD’ and index + as-is. + +Key: X f (magit-file-checkout) + Update file in the working tree and index to the contents from a + revision. Both the revision and file are read from the user. + + +File: doc5khxAZ.info, Node: Stashing, Prev: Resetting, Up: Manipulating + +6.12 Stashing +============= + +Also see [BROKEN LINK: man:git-stash] + +Key: z (magit-stash) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: z z (magit-stash-both) + Create a stash of the index and working tree. Untracked files are + included according to infix arguments. One prefix argument is + equivalent to ‘--include-untracked’ while two prefix arguments are + equivalent to ‘--all’. + +Key: z i (magit-stash-index) + Create a stash of the index only. Unstaged and untracked changes + are not stashed. + +Key: z w (magit-stash-worktree) + Create a stash of unstaged changes in the working tree. Untracked + files are included according to infix arguments. One prefix + argument is equivalent to ‘--include-untracked’ while two prefix + arguments are equivalent to ‘--all’. + +Key: z x (magit-stash-keep-index) + Create a stash of the index and working tree, keeping index intact. + Untracked files are included according to infix arguments. One + prefix argument is equivalent to ‘--include-untracked’ while two + prefix arguments are equivalent to ‘--all’. + +Key: z Z (magit-snapshot-both) + Create a snapshot of the index and working tree. Untracked files + are included according to infix arguments. One prefix argument is + equivalent to ‘--include-untracked’ while two prefix arguments are + equivalent to ‘--all’. + +Key: z I (magit-snapshot-index) + Create a snapshot of the index only. Unstaged and untracked + changes are not stashed. + +Key: z W (magit-snapshot-worktree) + Create a snapshot of unstaged changes in the working tree. + Untracked files are included according to infix arguments. One + prefix argument is equivalent to ‘--include-untracked’ while two + prefix arguments are equivalent to ‘--all’-. + +Key: z a (magit-stash-apply) + Apply a stash to the working tree. + + When using a Git release before v2.38.0, simply run ‘git stash + apply’ or with a prefix argument ‘git stash apply --index’. + + When using Git v2.38.0 or later, behave more intelligently: + + First try ‘git stash apply --index’, which tries to preserve the + index stored in the stash, if any. This may fail because applying + the stash could result in conflicts and those have to be stored in + the index, making it impossible to also store the stash’s index + there. + + If ‘git stash’ fails, then potentially fall back to using ‘git + apply’. If the stash does not touch any unstaged files, then pass + ‘--3way’ to that command. Otherwise ask the user whether to use + that argument or ‘--reject’. Customize ‘magit-no-confirm’ if you + want to fall back to using ‘--3way’, without being prompted. + +Key: z p (magit-stash-pop) + Apply a stash to the working tree. On complete success (if the + stash can be applied without any conflicts, and while preserving + the stash’s index) then remove the stash from stash list. + + When using a Git release before v2.38.0, simply run ‘git stash pop’ + or with a prefix argument ‘git stash pop --index’. + + When using Git v2.38.0 or later, behave more intelligently: + + First try ‘git stash pop --index’, which tries to preserve the + index stored in the stash, if any. This may fail because applying + the stash could result in conflicts and those have to be stored in + the index, making it impossible to also store the stash’s index + there. + + If ‘git stash’ fails, then potentially fall back to using ‘git + apply’. If the stash does not touch any unstaged files, then pass + ‘--3way’ to that command. Otherwise ask the user whether to use + that argument or ‘--reject’. Customize ‘magit-no-confirm’ if you + want to fall back to using ‘--3way’, without being prompted. + +Key: z k (magit-stash-drop) + Remove a stash from the stash list. When the region is active, + offer to drop all contained stashes. + +Key: z v (magit-stash-show) + Show all diffs of a stash in a buffer. + +Key: z b (magit-stash-branch) + Create and checkout a new branch from an existing stash. The new + branch starts at the commit that was current when the stash was + created. + +Key: z B (magit-stash-branch-here) + Create and checkout a new branch from an existing stash. Use the + current branch or ‘HEAD’ as the starting-point of the new branch. + Then apply the stash, dropping it if it applies cleanly. + +Key: z f (magit-stash-format-patch) + Create a patch from STASH. + +Key: k (magit-stash-clear) + Remove all stashes saved in REF’s reflog by deleting REF. + +Key: z l (magit-stash-list) + List all stashes in a buffer. + +User Option: magit-stashes-margin + This option specifies whether the margin is initially shown in + stashes buffers and how it is formatted. + + The value has the form ‘(INIT STYLE WIDTH AUTHOR AUTHOR-WIDTH)’. + + • If INIT is non-nil, then the margin is shown initially. + • STYLE controls how to format the author or committer date. It + can be one of ‘age’ (to show the age of the commit), + ‘age-abbreviated’ (to abbreviate the time unit to a + character), or a string (suitable for ‘format-time-string’) to + show the actual date. Option + ‘magit-log-margin-show-committer-date’ controls which date is + being displayed. + • WIDTH controls the width of the margin. This exists for + forward compatibility and currently the value should not be + changed. + • AUTHOR controls whether the name of the author is also shown + by default. + • AUTHOR-WIDTH has to be an integer. When the name of the + author is shown, then this specifies how much space is used to + do so. + + +File: doc5khxAZ.info, Node: Transferring, Next: Miscellaneous, Prev: Manipulating, Up: Top + +7 Transferring +************** + +* Menu: + +* Remotes:: +* Fetching:: +* Pulling:: +* Pushing:: +* Plain Patches:: +* Maildir Patches:: + + +File: doc5khxAZ.info, Node: Remotes, Next: Fetching, Up: Transferring + +7.1 Remotes +=========== + +* Menu: + +* Remote Commands:: +* Remote Git Variables:: + + +File: doc5khxAZ.info, Node: Remote Commands, Next: Remote Git Variables, Up: Remotes + +7.1.1 Remote Commands +--------------------- + +The transient prefix command ‘magit-remote’ is used to add remotes and +to make changes to existing remotes. This command only deals with +remotes themselves, not with branches or the transfer of commits. Those +features are available from separate transient commands. + + Also see [BROKEN LINK: man:git-remote] + +Key: M (magit-remote) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + + By default it also binds and displays the values of some + remote-related Git variables and allows changing their values. + +User Option: magit-remote-direct-configure + This option controls whether remote-related Git variables are + accessible directly from the transient ‘magit-remote’. + + If ‘t’ (the default) and a local branch is checked out, then + ‘magit-remote’ features the variables for the upstream remote of + that branch, or if ‘HEAD’ is detached, for ‘origin’, provided that + exists. + + If ‘nil’, then ‘magit-remote-configure’ has to be used to do so. + +Key: M C (magit-remote-configure) + This transient prefix command binds commands that set the value of + remote-related variables and displays them in a temporary buffer + until the transient is exited. + + With a prefix argument, this command always prompts for a remote. + + Without a prefix argument this depends on whether it was invoked as + a suffix of ‘magit-remote’ and on the + ‘magit-remote-direct-configure’ option. If ‘magit-remote’ already + displays the variables for the upstream, then it does not make + sense to invoke another transient that displays them for the same + remote. In that case this command prompts for a remote. + + The variables are described in *note Remote Git Variables::. + +Key: M a (magit-remote-add) + This command add a remote and fetches it. The remote name and url + are read in the minibuffer. + +Key: M r (magit-remote-rename) + This command renames a remote. Both the old and the new names are + read in the minibuffer. + +Key: M u (magit-remote-set-url) + This command changes the url of a remote. Both the remote and the + new url are read in the minibuffer. + +Key: M k (magit-remote-remove) + This command deletes a remote, read in the minibuffer. + +Key: M p (magit-remote-prune) + This command removes stale remote-tracking branches for a remote + read in the minibuffer. + +Key: M P (magit-remote-prune-refspecs) + This command removes stale refspecs for a remote read in the + minibuffer. + + A refspec is stale if there no longer exists at least one branch on + the remote that would be fetched due to that refspec. A stale + refspec is problematic because its existence causes Git to refuse + to fetch according to the remaining non-stale refspecs. + + If only stale refspecs remain, then this command offers to either + delete the remote or to replace the stale refspecs with the default + refspec ("+refs/heads/*:refs/remotes/REMOTE/*"). + + This command also removes the remote-tracking branches that were + created due to the now stale refspecs. Other stale branches are + not removed. + +User Option: magit-remote-add-set-remote.pushDefault + This option controls whether the user is asked whether they want to + set ‘remote.pushDefault’ after adding a remote. + + If ‘ask’, then users is always ask. If ‘ask-if-unset’, then the + user is only if the variable isn’t set already. If ‘nil’, then the + user isn’t asked and the variable isn’t set. If the value is a + string, then the variable is set without the user being asked, + provided that the name of the added remote is equal to that string + and the variable isn’t already set. + + +File: doc5khxAZ.info, Node: Remote Git Variables, Prev: Remote Commands, Up: Remotes + +7.1.2 Remote Git Variables +-------------------------- + +These variables can be set from the transient prefix command +‘magit-remote-configure’. By default they can also be set from +‘magit-remote’. See *note Remote Commands::. + +Variable: remote.NAME.url + This variable specifies the url of the remote named NAME. It can + have multiple values. + +Variable: remote.NAME.fetch + The refspec used when fetching from the remote named NAME. It can + have multiple values. + +Variable: remote.NAME.pushurl + This variable specifies the url used for pushing to the remote + named NAME. If it is not specified, then ‘remote.NAME.url’ is used + instead. It can have multiple values. + +Variable: remote.NAME.push + The refspec used when pushing to the remote named NAME. It can + have multiple values. + +Variable: remote.NAME.tagOpts + This variable specifies what tags are fetched by default. If the + value is ‘--no-tags’ then no tags are fetched. If the value is + ‘--tags’, then all tags are fetched. If this variable has no + value, then only tags are fetched that are reachable from fetched + branches. + + +File: doc5khxAZ.info, Node: Fetching, Next: Pulling, Prev: Remotes, Up: Transferring + +7.2 Fetching +============ + +Also see [BROKEN LINK: man:git-fetch] For information about the upstream +and the push-remote, see *note The Two Remotes::. + +Key: f (magit-fetch) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: f p (magit-fetch-from-pushremote) + This command fetches from the current push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +Key: f u (magit-fetch-from-upstream) + This command fetch from the upstream of the current branch. + + If the upstream is configured for the current branch and names an + existing remote, then use that. Otherwise try to use another + remote: If only a single remote is configured, then use that. + Otherwise if a remote named "origin" exists, then use that. + + If no remote can be determined, then this command is not available + from the ‘magit-fetch’ transient prefix and invoking it directly + results in an error. + +Key: f e (magit-fetch-other) + This command fetch from a repository read from the minibuffer. + +Key: f o (magit-fetch-branch) + This command fetches a branch from a remote, both of which are read + from the minibuffer. + +Key: f r (magit-fetch-refspec) + This command fetches from a remote using an explicit refspec, both + of which are read from the minibuffer. + +Key: f a (magit-fetch-all) + This command fetches from all remotes. + +Key: f m (magit-fetch-modules) + This command fetches all submodules. With a prefix argument, it + acts as a transient prefix command, allowing the caller to set + options. + +User Option: magit-pull-or-fetch + By default fetch and pull commands are available from separate + transient prefix command. Setting this to ‘t’ adds some (but not + all) of the above suffix commands to the ‘magit-pull’ transient. + + If you do that, then you might also want to change the key binding + for these prefix commands, e.g.: + + (setq magit-pull-or-fetch t) + (define-key magit-mode-map "f" 'magit-pull) ; was magit-fetch + (define-key magit-mode-map "F" nil) ; was magit-pull + + +File: doc5khxAZ.info, Node: Pulling, Next: Pushing, Prev: Fetching, Up: Transferring + +7.3 Pulling +=========== + +Also see [BROKEN LINK: man:git-pull] For information about the upstream +and the push-remote, see *note The Two Remotes::. + +Key: F (magit-pull) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: F p (magit-pull-from-pushremote) + This command pulls from the push-remote of the current branch. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +Key: F u (magit-pull-from-upstream) + This command pulls from the upstream of the current branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +Key: F e (magit-pull-branch) + This command pulls from a branch read in the minibuffer. + + +File: doc5khxAZ.info, Node: Pushing, Next: Plain Patches, Prev: Pulling, Up: Transferring + +7.4 Pushing +=========== + +Also see [BROKEN LINK: man:git-push] For information about the upstream +and the push-remote, see *note The Two Remotes::. + +Key: P (magit-push) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: P p (magit-push-current-to-pushremote) + This command pushes the current branch to its push-remote. + + With a prefix argument or when the push-remote is either not + configured or unusable, then let the user first configure the + push-remote. + +Key: P u (magit-push-current-to-upstream) + This command pushes the current branch to its upstream branch. + + With a prefix argument or when the upstream is either not + configured or unusable, then let the user first configure the + upstream. + +Key: P e (magit-push-current) + This command pushes the current branch to a branch read in the + minibuffer. + +Key: P o (magit-push-other) + This command pushes an arbitrary branch or commit somewhere. Both + the source and the target are read in the minibuffer. + +Key: P r (magit-push-refspecs) + This command pushes one or multiple refspecs to a remote, both of + which are read in the minibuffer. + + To use multiple refspecs, separate them with commas. Completion is + only available for the part before the colon, or when no colon is + used. + +Key: P m (magit-push-matching) + This command pushes all matching branches to another repository. + + If only one remote exists, then push to that. Otherwise prompt for + a remote, offering the remote configured for the current branch as + default. + +Key: P t (magit-push-tags) + This command pushes all tags to another repository. + + If only one remote exists, then push to that. Otherwise prompt for + a remote, offering the remote configured for the current branch as + default. + +Key: P T (magit-push-tag) + This command pushes a tag to another repository. + + One of the infix arguments, ‘--force-with-lease’, deserves a word of +caution. It is passed without a value, which means "permit a force push +as long as the remote-tracking branches match their counterparts on the +remote end". If you’ve set up a tool to do automatic fetches (Magit +itself does not provide such functionality), using ‘--force-with-lease’ +can be dangerous because you don’t actually control or know the state of +the remote-tracking refs. In that case, you should consider setting +‘push.useForceIfIncludes’ to ‘true’ (available since Git 2.30). + + Two more push commands exist, which by default are not available from +the push transient. See their doc-strings for instructions on how to +add them to the transient. + +Command: magit-push-implicitly args + This command pushes somewhere without using an explicit refspec. + + This command simply runs ‘git push -v [ARGS]’. ARGS are the infix + arguments. No explicit refspec arguments are used. Instead the + behavior depends on at least these Git variables: ‘push.default’, + ‘remote.pushDefault’, ‘branch..pushRemote’, + ‘branch..remote’, ‘branch..merge’, and + ‘remote..push’. + + If you add this suffix to a transient prefix without explicitly + specifying the description, then an attempt is made to predict what + this command will do. For example: + + (transient-insert-suffix 'magit-push \"p\" + '(\"i\" magit-push-implicitly))" + +Command: magit-push-to-remote remote args + This command pushes to the remote REMOTE without using an explicit + refspec. The remote is read in the minibuffer. + + This command simply runs ‘git push -v [ARGS] REMOTE’. ARGS are the + infix arguments. No refspec arguments are used. Instead the + behavior depends on at least these Git variables: ‘push.default’, + ‘remote.pushDefault’, ‘branch..pushRemote’, + ‘branch..remote’, ‘branch..merge’, and + ‘remote..push’. + + +File: doc5khxAZ.info, Node: Plain Patches, Next: Maildir Patches, Prev: Pushing, Up: Transferring + +7.5 Plain Patches +================= + +Key: W (magit-patch) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: W c (magit-patch-create) + This command creates patches for a set commits. If the region + marks several commits, then it creates patches for all of them. + Otherwise it functions as a transient prefix command, which + features several infix arguments and binds itself as a suffix + command. When this command is invoked as a suffix of itself, then + it creates a patch using the specified infix arguments. + +Key: w a (magit-patch-apply) + This command applies a patch. This is a transient prefix command, + which features several infix arguments and binds itself as a suffix + command. When this command is invoked as a suffix of itself, then + it applies a patch using the specified infix arguments. + +Key: W s (magit-patch-save) + This command creates a patch from the current diff. + + Inside ‘magit-diff-mode’ or ‘magit-revision-mode’ buffers, ‘C-x + C-w’ is also bound to this command. + + It is also possible to save a plain patch file by using ‘C-x C-w’ +inside a ‘magit-diff-mode’ or ‘magit-revision-mode’ buffer. + + +File: doc5khxAZ.info, Node: Maildir Patches, Prev: Plain Patches, Up: Transferring + +7.6 Maildir Patches +=================== + +Also see [BROKEN LINK: man:git-am] and [BROKEN LINK: man:git-apply] + +Key: w (magit-am) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: w w (magit-am-apply-patches) + This command applies one or more patches. If the region marks + files, then those are applied as patches. Otherwise this command + reads a file-name in the minibuffer, defaulting to the file at + point. + +Key: w m (magit-am-apply-maildir) + This command applies patches from a maildir. + +Key: w a (magit-patch-apply) + This command applies a plain patch. For a longer description see + *note Plain Patches::. This command is only available from the + ‘magit-am’ transient for historic reasons. + + When an "am" operation is in progress, then the transient instead +features the following suffix commands. + +Key: w w (magit-am-continue) + This command resumes the current patch applying sequence. + +Key: w s (magit-am-skip) + This command skips the stopped at patch during a patch applying + sequence. + +Key: w a (magit-am-abort) + This command aborts the current patch applying sequence. This + discards all changes made since the sequence started. + + +File: doc5khxAZ.info, Node: Miscellaneous, Next: Customizing, Prev: Transferring, Up: Top + +8 Miscellaneous +*************** + +* Menu: + +* Tagging:: +* Notes:: +* Submodules:: +* Subtree:: +* Worktree:: +* Sparse checkouts:: +* Bundle:: +* Common Commands:: +* Wip Modes:: +* Commands for Buffers Visiting Files:: +* Minor Mode for Buffers Visiting Blobs:: + + +File: doc5khxAZ.info, Node: Tagging, Next: Notes, Up: Miscellaneous + +8.1 Tagging +=========== + +Also see [BROKEN LINK: man:git-tag] + +Key: t (magit-tag) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: t t (magit-tag-create) + This command creates a new tag with the given NAME at REV. With a + prefix argument it creates an annotated tag. + +Key: t r (magit-tag-release) + This commands creates a release tag. It assumes that release tags + match ‘magit-release-tag-regexp’. + + First it prompts for the name of the new tag using the highest + existing tag as initial input and leaving it to the user to + increment the desired part of the version string. If you use + unconventional release tags or version numbers (e.g., + ‘v1.2.3-custom.1’), you can set the ‘magit-release-tag-regexp’ and + ‘magit-tag-version-regexp-alist’ variables. + + If ‘--annotate’ is enabled then it prompts for the message of the + new tag. The proposed tag message is based on the message of the + highest tag, provided that that contains the corresponding version + string and substituting the new version string for that. Otherwise + it proposes something like "Foo-Bar 1.2.3", given, for example, a + TAG "v1.2.3" and a repository located at something like + "/path/to/foo-bar". + +Key: t k (magit-tag-delete) + This command deletes one or more tags. If the region marks + multiple tags (and nothing else), then it offers to delete those. + Otherwise, it prompts for a single tag to be deleted, defaulting to + the tag at point. + +Key: t p (magit-tag-prune) + This command offers to delete tags missing locally from REMOTE, and + vice versa. + + +File: doc5khxAZ.info, Node: Notes, Next: Submodules, Prev: Tagging, Up: Miscellaneous + +8.2 Notes +========= + +Also see [BROKEN LINK: man:git-notes] + +Key: T (magit-notes) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + +Key: T T (magit-notes-edit) + Edit the note attached to a commit, defaulting to the commit at + point. + + By default use the value of Git variable ‘core.notesRef’ or + "refs/notes/commits" if that is undefined. + +Key: T r (magit-notes-remove) + Remove the note attached to a commit, defaulting to the commit at + point. + + By default use the value of Git variable ‘core.notesRef’ or + "refs/notes/commits" if that is undefined. + +Key: T p (magit-notes-prune) + Remove notes about unreachable commits. + + It is possible to merge one note ref into another. That may result +in conflicts which have to resolved in the temporary worktree +".git/NOTES_MERGE_WORKTREE". + +Key: T m (magit-notes-merge) + Merge the notes of a ref read from the user into the current notes + ref. The current notes ref is the value of Git variable + ‘core.notesRef’ or "refs/notes/commits" if that is undefined. + + When a notes merge is in progress then the transient features the +following suffix commands, instead of those listed above. + +Key: T c (magit-notes-merge-commit) + Commit the current notes ref merge, after manually resolving + conflicts. + +Key: T a (magit-notes-merge-abort) + Abort the current notes ref merge. + + The following variables control what notes reference ‘magit-notes-*’, +‘git notes’ and ‘git show’ act on and display. Both the local and +global values are displayed and can be modified. + +Variable: core.notesRef + This variable specifies the notes ref that is displayed by default + and which commands act on by default. + +Variable: notes.displayRef + This variable specifies additional notes ref to be displayed in + addition to the ref specified by ‘core.notesRef’. It can have + multiple values and may end with ‘*’ to display all refs in the + ‘refs/notes/’ namespace (or ‘**’ if some names contain slashes). + + +File: doc5khxAZ.info, Node: Submodules, Next: Subtree, Prev: Notes, Up: Miscellaneous + +8.3 Submodules +============== + +Also see [BROKEN LINK: man:git-submodule] + +* Menu: + +* Listing Submodules:: +* Submodule Transient:: + + +File: doc5khxAZ.info, Node: Listing Submodules, Next: Submodule Transient, Up: Submodules + +8.3.1 Listing Submodules +------------------------ + +The command ‘magit-list-submodules’ displays a list of the current +repository’s submodules in a separate buffer. It’s also possible to +display information about submodules directly in the status buffer of +the super-repository by adding ‘magit-insert-modules’ to the hook +‘magit-status-sections-hook’ as described in *note Status Module +Sections::. + +Command: magit-list-submodules + This command displays a list of the current repository’s populated + submodules in a separate buffer. + + It can be invoked by pressing ‘RET’ on the section titled + "Modules". + +User Option: magit-submodule-list-columns + This option controls what columns are displayed by the command + ‘magit-list-submodules’ and how they are displayed. + + Each element has the form ‘(HEADER WIDTH FORMAT PROPS)’. + + HEADER is the string displayed in the header. WIDTH is the width + of the column. FORMAT is a function that is called with one + argument, the repository identification (usually its basename), and + with ‘default-directory’ bound to the toplevel of its working tree. + It has to return a string to be inserted or nil. PROPS is an alist + that supports the keys ‘:right-align’, ‘:pad-right’ and ‘:sort’. + + The ‘:sort’ function has a weird interface described in the + docstring of ‘tabulated-list--get-sort’. Alternatively ‘<’ and + ‘magit-repolist-version<’ can be used as those functions are + automatically replaced with functions that satisfy the interface. + Set ‘:sort’ to ‘nil’ to inhibit sorting; if unspecified, then the + column is sortable using the default sorter. + + You may wish to display a range of numeric columns using just one + character per column and without any padding between columns, in + which case you should use an appropriate HEADER, set WIDTH to 1, + and set ‘:pad-right’ to 9. ‘+’ is substituted for numbers higher + than 9. + + +File: doc5khxAZ.info, Node: Submodule Transient, Prev: Listing Submodules, Up: Submodules + +8.3.2 Submodule Transient +------------------------- + +Key: o (magit-submodule) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + Some of the below commands default to act on the modules that are +selected using the region. For brevity their description talk about +"the selected modules", but if no modules are selected, then they act on +the current module instead, or if point isn’t on a module, then the read +a single module to act on. With a prefix argument these commands ignore +the selection and the current module and instead act on all suitable +modules. + +Key: o a (magit-submodule-add) + This commands adds the repository at URL as a module. Optional + PATH is the path to the module relative to the root of the + super-project. If it is nil then the path is determined based on + URL. + +Key: o r (magit-submodule-register) + This command registers the selected modules by copying their urls + from ".gitmodules" to "$GIT_DIR/config". These values can then be + edited before running ‘magit-submodule-populate’. If you don’t + need to edit any urls, then use the latter directly. + +Key: o p (magit-submodule-populate) + This command creates the working directory or directories of the + selected modules, checking out the recorded commits. + +Key: o u (magit-submodule-update) + This command updates the selected modules checking out the recorded + commits. + +Key: o s (magit-submodule-synchronize) + This command synchronizes the urls of the selected modules, copying + the values from ".gitmodules" to the ".git/config" of the + super-project as well those of the modules. + +Key: o d (magit-submodule-unpopulate) + This command removes the working directory of the selected modules. + +Key: o l (magit-list-submodules) + This command displays a list of the current repository’s modules. + +Key: o f (magit-fetch-modules) + This command fetches all populated modules. With a prefix + argument, it acts as a transient prefix command, allowing the + caller to set options. + + Also fetch the super-repository, because ‘git fetch’ does not + support not doing that. + + +File: doc5khxAZ.info, Node: Subtree, Next: Worktree, Prev: Submodules, Up: Miscellaneous + +8.4 Subtree +=========== + +Also see [BROKEN LINK: man:git-subtree] + +Key: O (magit-subtree) + This transient prefix command binds the two sub-transients; one for + importing a subtree and one for exporting a subtree. + +Key: O i (magit-subtree-import) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + The suffixes of this command import subtrees. + + If the ‘--prefix’ argument is set, then the suffix commands use + that prefix without prompting the user. If it is unset, then they + read the prefix in the minibuffer. + +Key: O i a (magit-subtree-add) + This command adds COMMIT from REPOSITORY as a new subtree at + PREFIX. + +Key: O i c (magit-subtree-add-commit) + This command add COMMIT as a new subtree at PREFIX. + +Key: O i m (magit-subtree-merge) + This command merges COMMIT into the PREFIX subtree. + +Key: O i f (magit-subtree-pull) + This command pulls COMMIT from REPOSITORY into the PREFIX subtree. + +Key: O e (magit-subtree-export) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + The suffixes of this command export subtrees. + + If the ‘--prefix’ argument is set, then the suffix commands use + that prefix without prompting the user. If it is unset, then they + read the prefix in the minibuffer. + +Key: O e p (magit-subtree-push) + This command extract the history of the subtree PREFIX and pushes + it to REF on REPOSITORY. + +Key: O e s (magit-subtree-split) + This command extracts the history of the subtree PREFIX. + + +File: doc5khxAZ.info, Node: Worktree, Next: Sparse checkouts, Prev: Subtree, Up: Miscellaneous + +8.5 Worktree +============ + +Also see [BROKEN LINK: man:git-worktree] + +Key: Z (magit-worktree) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: Z b (magit-worktree-checkout) + Checkout BRANCH in a new worktree at PATH. + +Key: Z c (magit-worktree-branch) + Create a new BRANCH and check it out in a new worktree at PATH. + +Key: Z m (magit-worktree-move) + Move an existing worktree to a new PATH. + +Key: Z k (magit-worktree-delete) + Delete a worktree, defaulting to the worktree at point. The + primary worktree cannot be deleted. + +Key: Z g (magit-worktree-status) + Show the status for the worktree at point. + + If there is no worktree at point, then read one in the minibuffer. + If the worktree at point is the one whose status is already being + displayed in the current buffer, then show it in Dired instead. + + +File: doc5khxAZ.info, Node: Sparse checkouts, Next: Bundle, Prev: Worktree, Up: Miscellaneous + +8.6 Sparse checkouts +==================== + +Sparse checkouts provide a way to restrict the working tree to a subset +of directories. See [BROKEN LINK: man:git-sparse-checkout] + + *Warning*: Git introduced the ‘git sparse-checkout’ command in +version 2.25 and still advertises it as experimental and subject to +change. Magit’s interface should be considered the same. In +particular, if Git introduces a backward incompatible change, Magit’s +sparse checkout functionality may be updated in a way that requires a +more recent Git version. + +Key: > (magit-sparse-checkout) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: > e (magit-sparse-checkout-enable) + This command initializes a sparse checkout that includes only the + files in the top-level directory. + + Note that ‘magit-sparse-checkout-set’ and + ‘magit-sparse-checkout-add’ automatically initialize a sparse + checkout if necessary. However, you may want to call + ‘magit-sparse-checkout-enable’ explicitly to re-initialize a sparse + checkout after calling ‘magit-sparse-checkout-disable’, to pass + additional arguments to ‘git sparse-checkout init’, or to execute + the initialization asynchronously. + +Key: > s (magit-sparse-checkout-set) + This command takes a list of directories and configures the sparse + checkout to include only files in those subdirectories. Any + previously included directories are excluded unless they are in the + provided list of directories. + +Key: > a (magit-sparse-checkout-add) + This command is like ‘magit-sparse-checkout-set’, but instead adds + the specified list of directories to the set of directories that is + already included in the sparse checkout. + +Key: > r (magit-sparse-checkout-reapply) + This command applies the currently configured sparse checkout + patterns to the working tree. This is useful to call if excluded + files have been checked out after operations such as merging or + rebasing. + +Key: > d (magit-sparse-checkout-disable) + This command restores the full checkout. To return to the previous + sparse checkout, call ‘magit-sparse-checkout-enable’. + + A sparse checkout can also be initiated when cloning a repository by +using the ‘magit-clone-sparse’ command in the ‘magit-clone’ transient +(see *note Cloning Repository::). + + If you want the status buffer to indicate when a sparse checkout is +enabled, add the function ‘magit-sparse-checkout-insert-header’ to +‘magit-status-headers-hook’. + + +File: doc5khxAZ.info, Node: Bundle, Next: Common Commands, Prev: Sparse checkouts, Up: Miscellaneous + +8.7 Bundle +========== + +Also see [BROKEN LINK: man:git-bundle] + +Command: magit-bundle + This transient prefix command binds several suffix commands for + running ‘git bundle’ subcommands and displays them in a temporary + buffer until a suffix is invoked. + + +File: doc5khxAZ.info, Node: Common Commands, Next: Wip Modes, Prev: Bundle, Up: Miscellaneous + +8.8 Common Commands +=================== + +Command: magit-switch-to-repository-buffer + +Command: magit-switch-to-repository-buffer-other-window + +Command: magit-switch-to-repository-buffer-other-frame + +Command: magit-display-repository-buffer + These commands read any existing Magit buffer that belongs to the + current repository from the user and then switch to the selected + buffer (without refreshing it). + + The last variant uses ‘magit-display-buffer’ to do so and thus + respects ‘magit-display-buffer-function’. + + These are some of the commands that can be used in all buffers whose +major-modes derive from ‘magit-mode’. There are other common commands +beside the ones below, but these didn’t fit well anywhere else. + +Key: C-w (magit-copy-section-value) + This command saves the value of the current section to the + ‘kill-ring’, and, provided that the current section is a commit, + branch, or tag section, it also pushes the (referenced) revision to + the ‘magit-revision-stack’. + + When the current section is a branch or a tag, and a prefix + argument is used, then it saves the revision at its tip to the + ‘kill-ring’ instead of the reference name. + + When the region is active, this command saves that to the + ‘kill-ring’, like ‘kill-ring-save’ would, instead of behaving as + described above. If a prefix argument is used and the region is + within a hunk, then it strips the diff marker column and keeps only + either the added or removed lines, depending on the sign of the + prefix argument. + +Key: M-w (magit-copy-buffer-revision) + This command saves the revision being displayed in the current + buffer to the ‘kill-ring’ and also pushes it to the + ‘magit-revision-stack’. It is mainly intended for use in + ‘magit-revision-mode’ buffers, the only buffers where it is always + unambiguous exactly which revision should be saved. + + Most other Magit buffers usually show more than one revision, in + some way or another, so this command has to select one of them, and + that choice might not always be the one you think would have been + the best pick. + + Outside of Magit ‘M-w’ and ‘C-w’ are usually bound to +‘kill-ring-save’ and ‘kill-region’, and these commands would also be +useful in Magit buffers. Therefore when the region is active, then both +of these commands behave like ‘kill-ring-save’ instead of as described +above. + + +File: doc5khxAZ.info, Node: Wip Modes, Next: Commands for Buffers Visiting Files, Prev: Common Commands, Up: Miscellaneous + +8.9 Wip Modes +============= + +Git keeps *committed* changes around long enough for users to recover +changes they have accidentally deleted. It does so by not garbage +collecting any committed but no longer referenced objects for a certain +period of time, by default 30 days. + + But Git does *not* keep track of *uncommitted* changes in the working +tree and not even the index (the staging area). Because Magit makes it +so convenient to modify uncommitted changes, it also makes it easy to +shoot yourself in the foot in the process. + + For that reason Magit provides a global mode that saves *tracked* +files to work-in-progress references after or before certain actions. +(At present untracked files are never saved and for technical reasons +nothing is saved before the first commit has been created). + + Two separate work-in-progress references are used to track the state +of the index and of the working tree: ‘refs/wip/index/’ and +‘refs/wip/wtree/’, where ‘’ is the full ref of the +current branch, e.g., ‘refs/heads/master’. When the ‘HEAD’ is detached +then ‘HEAD’ is used in place of ‘’. + + Checking out another branch (or detaching ‘HEAD’) causes the use of +different wip refs for subsequent changes. + +User Option: magit-wip-mode + When this mode is enabled, then uncommitted changes are committed + to dedicated work-in-progress refs whenever appropriate (i.e., when + dataloss would be a possibility otherwise). + + Setting this variable directly does not take effect; either use the + Custom interface to do so or call the respective mode function. + + For historic reasons this mode is implemented on top of four other + ‘magit-wip-*’ modes, which can also be used individually, if you + want finer control over when the wip refs are updated; but that is + discouraged. See *note Legacy Wip Modes::. + + To view the log for a branch and its wip refs use the commands +‘magit-wip-log’ and ‘magit-wip-log-current’. You should use ‘--graph’ +when using these commands. + +Command: magit-wip-log + This command shows the log for a branch and its wip refs. With a + negative prefix argument only the worktree wip ref is shown. + + The absolute numeric value of the prefix argument controls how many + "branches" of each wip ref are shown. This is only relevant if the + value of ‘magit-wip-merge-branch’ is ‘nil’. + +Command: magit-wip-log-current + This command shows the log for the current branch and its wip refs. + With a negative prefix argument only the worktree wip ref is shown. + + The absolute numeric value of the prefix argument controls how many + "branches" of each wip ref are shown. This is only relevant if the + value of ‘magit-wip-merge-branch’ is ‘nil’. + +Key: X w (magit-reset-worktree) + This command resets the working tree to some commit read from the + user and defaulting to the commit at point, while keeping the + ‘HEAD’ and index as-is. + + This can be used to restore files to the state committed to a wip + ref. Note that this will discard any unstaged changes that might + have existed before invoking this command (but of course only after + committing that to the working tree wip ref). + + Note that even if you enable ‘magit-wip-mode’ this won’t give you +perfect protection. The most likely scenario for losing changes despite +the use of ‘magit-wip-mode’ is making a change outside Emacs and then +destroying it also outside Emacs. In some such a scenario, Magit, being +an Emacs package, didn’t get the opportunity to keep you from shooting +yourself in the foot. + + When you are unsure whether Magit did commit a change to the wip +refs, then you can explicitly request that all changes to all tracked +files are being committed. + +Key: M-x magit-wip-commit + This command commits all changes to all tracked files to the index + and working tree work-in-progress refs. Like the modes described + above, it does not commit untracked files, but it does check all + tracked files for changes. Use this command when you suspect that + the modes might have overlooked a change made outside Emacs/Magit. + +User Option: magit-wip-namespace + The namespace used for work-in-progress refs. It has to end with a + slash. The wip refs are named ‘index/’ and + ‘wtree/’. When snapshots are created while + the ‘HEAD’ is detached then ‘HEAD’ is used in place of + ‘’. + +User Option: magit-wip-mode-lighter + Mode-line lighter for ‘magit-wip--mode’. + +* Menu: + +* Wip Graph:: +* Legacy Wip Modes:: + + +File: doc5khxAZ.info, Node: Wip Graph, Next: Legacy Wip Modes, Up: Wip Modes + +8.9.1 Wip Graph +--------------- + +User Option: magit-wip-merge-branch + This option controls whether the current branch is merged into the + wip refs after a new commit was created on the branch. + + If non-nil and the current branch has new commits, then it is + merged into the wip ref before creating a new wip commit. This + makes it easier to inspect wip history and the wip commits are + never garbage collected. + + If nil and the current branch has new commits, then the wip ref is + reset to the tip of the branch before creating a new wip commit. + With this setting wip commits are eventually garbage collected. + + When ‘magit-wip-merge-branch’ is ‘t’, then the history looks like +this: + + *--*--*--*--*--* refs/wip/index/refs/heads/master + / / / + A-----B-----C refs/heads/master + + When ‘magit-wip-merge-branch’ is ‘nil’, then creating a commit on the +real branch and then making a change causes the wip refs to be recreated +to fork from the new commit. But the old commits on the wip refs are +not lost. They are still available from the reflog. To make it easier +to see when the fork point of a wip ref was changed, an additional +commit with the message "restart autosaving" is created on it (‘xxO’ +commits below are such boundary commits). + + Starting with + + BI0---BI1 refs/wip/index/refs/heads/master + / + A---B refs/heads/master + \ + BW0---BW1 refs/wip/wtree/refs/heads/master + + and committing the staged changes and editing and saving a file would +result in + + BI0---BI1 refs/wip/index/refs/heads/master + / + A---B---C refs/heads/master + \ \ + \ CW0---CW1 refs/wip/wtree/refs/heads/master + \ + BW0---BW1 refs/wip/wtree/refs/heads/master@{2} + + The fork-point of the index wip ref is not changed until some change +is being staged. Likewise just checking out a branch or creating a +commit does not change the fork-point of the working tree wip ref. The +fork-points are not adjusted until there actually is a change that +should be committed to the respective wip ref. + + +File: doc5khxAZ.info, Node: Legacy Wip Modes, Prev: Wip Graph, Up: Wip Modes + +8.9.2 Legacy Wip Modes +---------------------- + +It is recommended that you use the mode ‘magit-wip-mode’ (which see) and +ignore the existence of the following modes, which are preserved for +historic reasons. + + Setting the following variables directly does not take effect; either +use the Custom interface to do so or call the respective mode functions. + +User Option: magit-wip-after-save-mode + When this mode is enabled, then saving a buffer that visits a file + tracked in a Git repository causes its current state to be + committed to the working tree wip ref for the current branch. + +User Option: magit-wip-after-apply-mode + When this mode is enabled, then applying (i.e., staging, unstaging, + discarding, reversing, and regularly applying) a change to a file + tracked in a Git repository causes its current state to be + committed to the index and/or working tree wip refs for the current + branch. + + If you only ever edit files using Emacs and only ever interact with +Git using Magit, then the above two modes should be enough to protect +each and every change from accidental loss. In practice nobody does +that. Two additional modes exists that do commit to the wip refs before +making changes that could cause the loss of earlier changes. + +User Option: magit-wip-before-change-mode + When this mode is enabled, then certain commands commit the + existing changes to the files they are about to make changes to. + +User Option: magit-wip-initial-backup-mode + When this mode is enabled, then the current version of a file is + committed to the worktree wip ref before the buffer visiting that + file is saved for the first time since the buffer was created. + + This backs up the same version of the file that ‘backup-buffer’ + would save. While ‘backup-buffer’ uses a backup file, this mode + uses the same worktree wip ref as used by the other Magit Wip + modes. Like ‘backup-buffer’, it only does this once; unless you + kill the buffer and visit the file again only one backup will be + created per Emacs session. + + This mode ignores the variables that affect ‘backup-buffer’ and can + be used along-side that function, which is recommended because it + only backs up files that are tracked in a Git repository. + +User Option: magit-wip-after-save-local-mode-lighter + Mode-line lighter for ‘magit-wip-after-save-local-mode’. + +User Option: magit-wip-after-apply-mode-lighter + Mode-line lighter for ‘magit-wip-after-apply-mode’. + +User Option: magit-wip-before-change-mode-lighter + Mode-line lighter for ‘magit-wip-before-change-mode’. + +User Option: magit-wip-initial-backup-mode-lighter + Mode-line lighter for ‘magit-wip-initial-backup-mode’. + + +File: doc5khxAZ.info, Node: Commands for Buffers Visiting Files, Next: Minor Mode for Buffers Visiting Blobs, Prev: Wip Modes, Up: Miscellaneous + +8.10 Commands for Buffers Visiting Files +======================================== + +By default Magit defines a few global key bindings. These bindings are +a compromise between providing no bindings at all and providing the +better bindings I would have liked to use instead. Magit cannot provide +the set of recommended bindings by default because those key sequences +are strictly reserved for bindings added by the user. Also see *note +Global Bindings:: and *note (elisp)Key Binding Conventions::. + + To use the recommended bindings, add this to your init file and +restart Emacs. + + (setq magit-define-global-key-bindings 'recommended) + + If you don’t want Magit to add any bindings to the global keymap at +all, add this to your init file and restart Emacs. + + (setq magit-define-global-key-bindings nil) + +Key: C-c f (magit-file-dispatch) + +Key: C-c f s (magit-stage-file) + +Key: C-c f s (magit-stage-buffer-file) + +Key: C-c f u (magit-unstage-file) + +Key: C-c f u (magit-unstage-buffer-file) + +Key: C-c f , x (magit-file-untrack) + +Key: C-c f , r (magit-file-rename) + +Key: C-c f , k (magit-file-delete) + +Key: C-c f , c (magit-file-checkout) + +Key: C-c f D (magit-diff) + +Key: C-c f d (magit-diff-buffer-file) + +Key: C-c f L (magit-log) + +Key: C-c f l (magit-log-buffer-file) + +Key: C-c f t (magit-log-trace-definition) + +Key: C-c f M (magit-log-merged) + +Key: C-c f B (magit-blame) + +Key: C-c f b (magit-blame-additions) + +Key: C-c f r (magit-blame-removal) + +Key: C-c f f (magit-blame-reverse) + +Key: C-c f m (magit-blame-echo) + +Key: C-c f q (magit-blame-quit) + +Key: C-c f p (magit-blob-previous) + +Key: C-c f n (magit-blob-next) + +Key: C-c f v (magit-find-file) + +Key: C-c f V (magit-blob-visit-file) + +Key: C-c f g (magit-status-here) + +Key: C-c f G (magit-display-repository-buffer) + +Key: C-c f c (magit-commit) + +Key: C-c f e (magit-edit-line-commit) + Each of these commands is documented individually right below, + alongside their default key bindings. The bindings shown above are + the recommended bindings, which you can enable by following the + instructions further up. + +Key: C-c M-g (magit-file-dispatch) + This transient prefix command binds the following suffix commands + and displays them in a temporary buffer until a suffix is invoked. + +Key: C-c M-g s (magit-stage-file) + +Key: C-c M-g s (magit-stage-buffer-file) + Stage all changes to the file being visited in the current buffer. + When not visiting a file, then the first command is used, which + prompts for a file. + +Key: C-c M-g u (magit-unstage-file) + +Key: C-c M-g u (magit-unstage-buffer-file) + Unstage all changes to the file being visited in the current + buffer. When not visiting a file, then the first command is used, + which prompts for a file. + +Key: C-c M-g , x (magit-file-untrack) + This command untracks a file read from the user, defaulting to the + visited file. + +Key: C-c M-g , r (magit-file-rename) + This command renames a file read from the user, defaulting to the + visited file. + +Key: C-c M-g , k (magit-file-delete) + This command deletes a file read from the user, defaulting to the + visited file. + +Key: C-c M-g , c (magit-file-checkout) + This command updates a file in the working tree and index to the + contents from a revision. Both the revision and file are read from + the user. + +Key: C-c M-g D (magit-diff) + This transient prefix command binds several diff suffix commands + and infix arguments and displays them in a temporary buffer until a + suffix is invoked. See *note Diffing::. + + This is the same command that ‘d’ is bound to in Magit buffers. If + this command is invoked from a file-visiting buffer, then the + initial value of the option (‘--’) that limits the diff to certain + file(s) is set to the visited file. + +Key: C-c M-g d (magit-diff-buffer-file) + This command shows the diff for the file of blob that the current + buffer visits. + +User Option: magit-diff-buffer-file-locked + This option controls whether ‘magit-diff-buffer-file’ uses a + dedicated buffer. See *note Modes and Buffers::. + +Key: C-c M-g L (magit-log) + This transient prefix command binds several log suffix commands and + infix arguments and displays them in a temporary buffer until a + suffix is invoked. See *note Logging::. + + This is the same command that ‘l’ is bound to in Magit buffers. If + this command is invoked from a file-visiting buffer, then the + initial value of the option (‘--’) that limits the log to certain + file(s) is set to the visited file. + +Key: C-c M-g l (magit-log-buffer-file) + This command shows the log for the file of blob that the current + buffer visits. Renames are followed when a prefix argument is used + or when ‘--follow’ is an active log argument. When the region is + active, the log is restricted to the selected line range. + +User Option: magit-log-buffer-file-locked + This option controls whether ‘magit-log-buffer-file’ uses a + dedicated buffer. See *note Modes and Buffers::. + +Key: C-c M-g t (magit-log-trace-definition) + This command shows the log for the definition at point. + +Key: C-c M-g M (magit-log-merged) + This command reads a commit and a branch in shows a log concerning + the merge of the former into the latter. This shows multiple + commits even in case of a fast-forward merge. + +Key: C-c M-g B (magit-blame) + This transient prefix command binds all blaming suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. + + For more information about this and the following commands also see + *note Blaming::. + + In addition to the ‘magit-blame’ sub-transient, the dispatch + transient also binds several blaming suffix commands directly. See + *note Blaming:: for information about those commands and bindings. + +Key: C-c M-g p (magit-blob-previous) + This command visits the previous blob which modified the current + file. + +Key: C-c M-g n (magit-blob-next) + This command visits the next blob which modified the current file. + +Key: C-c M-g v (magit-find-file) + This command reads a revision and file and visits the respective + blob. + +Key: C-c M-g V (magit-blob-visit-file) + This command visits the file from the working tree, corresponding + to the current blob. When visiting a blob or the version from the + index, then it goes to the same location in the respective file in + the working tree. + +Key: C-c M-g g (magit-status-here) + This command displays the status of the current repository in a + buffer, like ‘magit-status’ does. Additionally it tries to go to + the position in that buffer, which corresponds to the position in + the current file-visiting buffer (if any). + +Key: C-c M-g G (magit-display-repository-buffer) + This command reads and displays a Magit buffer belonging to the + current repository, without refreshing it. + +Key: C-c M-g c (magit-commit) + This transient prefix command binds the following suffix commands + along with the appropriate infix arguments and displays them in a + temporary buffer until a suffix is invoked. See *note Initiating a + Commit::. + +Key: C-c M-g e (magit-edit-line-commit) + This command makes the commit editable that added the current line. + + With a prefix argument it makes the commit editable that removes + the line, if any. The commit is determined using ‘git blame’ and + made editable using ‘git rebase --interactive’ if it is reachable + from ‘HEAD’, or by checking out the commit (or a branch that points + at it) otherwise. + + +File: doc5khxAZ.info, Node: Minor Mode for Buffers Visiting Blobs, Prev: Commands for Buffers Visiting Files, Up: Miscellaneous + +8.11 Minor Mode for Buffers Visiting Blobs +========================================== + +The ‘magit-blob-mode’ enables certain Magit features in blob-visiting +buffers. Such buffers can be created using ‘magit-find-file’ and some +of the commands mentioned below, which also take care of turning on this +minor mode. Currently this mode only establishes a few key bindings, +but this might be extended. + +Key: p (magit-blob-previous) + Visit the previous blob which modified the current file. + +Key: n (magit-blob-next) + Visit the next blob which modified the current file. + +Key: q (magit-kill-this-buffer) + Kill the current buffer. + + +File: doc5khxAZ.info, Node: Customizing, Next: Plumbing, Prev: Miscellaneous, Up: Top + +9 Customizing +************* + +Both Git and Emacs are highly customizable. Magit is both a Git +porcelain as well as an Emacs package, so it makes sense to customize it +using both Git variables as well as Emacs options. However this +flexibility doesn’t come without problems, including but not limited to +the following. + + • Some Git variables automatically have an effect in Magit without + requiring any explicit support. Sometimes that is desirable - in + other cases, it breaks Magit. + + When a certain Git setting breaks Magit but you want to keep using + that setting on the command line, then that can be accomplished by + overriding the value for Magit only by appending something like + ‘("-c" "some.variable=compatible-value")’ to + ‘magit-git-global-arguments’. + + • Certain settings like ‘fetch.prune=true’ are respected by Magit + commands (because they simply call the respective Git command) but + their value is not reflected in the respective transient buffers. + In this case the ‘--prune’ argument in ‘magit-fetch’ might be + active or inactive, but that doesn’t keep the Git variable from + being honored by the suffix commands anyway. So pruning might + happen despite the ‘--prune’ arguments being displayed in a way + that seems to indicate that no pruning will happen. + + I intend to address these and similar issues in a future release. + +* Menu: + +* Per-Repository Configuration:: +* Essential Settings:: + + +File: doc5khxAZ.info, Node: Per-Repository Configuration, Next: Essential Settings, Up: Customizing + +9.1 Per-Repository Configuration +================================ + +Magit can be configured on a per-repository level using both Git +variables as well as Emacs options. + + To set a Git variable for one repository only, simply set it in +‘/path/to/repo/.git/config’ instead of ‘$HOME/.gitconfig’ or +‘/etc/gitconfig’. See [BROKEN LINK: man:git-config] + + Similarly, Emacs options can be set for one repository only by +editing ‘/path/to/repo/.dir-locals.el’. See *note (emacs)Directory +Variables::. For example to disable automatic refreshes of +file-visiting buffers in just one huge repository use this: + + • ‘/path/to/huge/repo/.dir-locals.el’ + + ((nil . ((magit-refresh-buffers . nil)))) + + It might only be costly to insert certain information into Magit +buffers for repositories that are exceptionally large, in which case you +can disable the respective section inserters just for that repository: + + • ‘/path/to/tag/invested/repo/.dir-locals.el’ + + ((magit-status-mode + . ((eval . (magit-disable-section-inserter 'magit-insert-tags-header))))) + +Function: magit-disable-section-inserter fn + This function disables the section inserter FN in the current + repository. It is only intended for use in ‘.dir-locals.el’ and + ‘.dir-locals-2.el’. + + If you want to apply the same settings to several, but not all, +repositories then keeping the repository-local config files in sync +would quickly become annoying. To avoid that you can create config +files for certain classes of repositories (e.g., "huge repositories") +and then include those files in the per-repository config files. For +example: + + • ‘/path/to/huge/repo/.git/config’ + + [include] + path = /path/to/huge-gitconfig + + • ‘/path/to/huge-gitconfig’ + + [status] + showUntrackedFiles = no + + • ‘$HOME/.emacs.d/init.el’ + + (dir-locals-set-class-variables 'huge-git-repository + '((nil . ((magit-refresh-buffers . nil))))) + + (dir-locals-set-directory-class + "/path/to/huge/repo/" 'huge-git-repository) + + +File: doc5khxAZ.info, Node: Essential Settings, Prev: Per-Repository Configuration, Up: Customizing + +9.2 Essential Settings +====================== + +The next three sections list and discuss several variables that many +users might want to customize, for safety and/or performance reasons. + +* Menu: + +* Safety:: +* Performance:: +* Global Bindings:: + + +File: doc5khxAZ.info, Node: Safety, Next: Performance, Up: Essential Settings + +9.2.1 Safety +------------ + +This section discusses various variables that you might want to change +(or *not* change) for safety reasons. + + Git keeps *committed* changes around long enough for users to recover +changes they have accidentally been deleted. It does not do the same +for *uncommitted* changes in the working tree and not even the index +(the staging area). Because Magit makes it so easy to modify +uncommitted changes, it also makes it easy to shoot yourself in the foot +in the process. For that reason Magit provides three global modes that +save *tracked* files to work-in-progress references after or before +certain actions. See *note Wip Modes::. + + These modes are not enabled by default because of performance +concerns. Instead a lot of potentially destructive commands require +confirmation every time they are used. In many cases this can be +disabled by adding a symbol to ‘magit-no-confirm’ (see *note Completion +and Confirmation::). If you enable the various wip modes then you +should add ‘safe-with-wip’ to this list. + + Similarly it isn’t necessary to require confirmation before moving a +file to the system trash - if you trashed a file by mistake then you can +recover it from there. Option ‘magit-delete-by-moving-to-trash’ +controls whether the system trash is used, which is the case by default. +Nevertheless, ‘trash’ isn’t a member of ‘magit-no-confirm’ - you might +want to change that. + + By default buffers visiting files are automatically reverted when the +visited file changes on disk. This isn’t as risky as it might seem, but +to make an informed decision you should see *note Risk of Reverting +Automatically::. + + +File: doc5khxAZ.info, Node: Performance, Next: Global Bindings, Prev: Safety, Up: Essential Settings + +9.2.2 Performance +----------------- + +After Magit has run ‘git’ for side-effects, it also refreshes the +current Magit buffer and the respective status buffer. This is +necessary because otherwise outdated information might be displayed +without the user noticing. Magit buffers are updated by recreating +their content from scratch, which makes updating simpler and less +error-prone, but also more costly. Keeping it simple and just +re-creating everything from scratch is an old design decision and +departing from that will require major refactoring. + + Meanwhile you can tell Magit to only automatically refresh the +current Magit buffer, but not the status buffer. If you do that, then +the status buffer is only refreshed automatically if it is the current +buffer. + + (setq magit-refresh-status-buffer nil) + + You should also check whether any third-party packages have added +anything to ‘magit-refresh-buffer-hook’, ‘magit-pre-refresh-hook’, and +‘magit-post-refresh-hook’. If so, then check whether those additions +impact performance significantly. + + Magit can be told to refresh buffers verbosely using ‘M-x +magit-toggle-verbose-refresh’. Enabling this helps figuring out which +sections are bottlenecks. Each line printed to the ‘*Messages*’ buffer +contains a section name, the number of seconds it took to show this +section, and from 0 to 2 exclamation marks: the more exclamation marks +the slower the section is. + + Magit also reverts buffers for visited files located inside the +current repository when the visited file changes on disk. That is +implemented on top of ‘auto-revert-mode’ from the built-in library +‘autorevert’. To figure out whether that impacts performance, check +whether performance is significantly worse, when many buffers exist +and/or when some buffers visit files using TRAMP. If so, then this +should help. + + (setq auto-revert-buffer-list-filter + 'magit-auto-revert-repository-buffer-p) + + For alternative approaches see *note Automatic Reverting of +File-Visiting Buffers::. + + If you have enabled any features that are disabled by default, then +you should check whether they impact performance significantly. It’s +likely that they were not enabled by default because it is known that +they reduce performance at least in large repositories. + + If performance is only slow inside certain unusually large +repositories, then you might want to disable certain features on a +per-repository or per-repository-class basis only. See *note +Per-Repository Configuration::. For example it takes a long time to +determine the next and current tag in repository with exceptional +numbers of tags. It would therefore be a good idea to disable +‘magit-insert-tags-headers’, as explained at the mentioned node. + +* Menu: + +* Microsoft Windows Performance:: +* MacOS Performance:: + +Log Performance +............... + +When showing logs, Magit limits the number of commits initially shown in +the hope that this avoids unnecessary work. When ‘--graph’ is used, +then this unfortunately does not have the desired effect for large +histories. Junio, Git’s maintainer, said on the Git mailing list +(): "‘--graph’ wants +to compute the whole history and the max-count only affects the output +phase after ‘--graph’ does its computation". + + In other words, it’s not that Git is slow at outputting the +differences, or that Magit is slow at parsing the output - the problem +is that Git first goes outside and has a smoke. + + We actually work around this issue by limiting the number of commits +not only by using ‘-’ but by also using a range. But unfortunately +that’s not always possible. + + When more than a few thousand commits are shown, then the use of +‘--graph’ can slow things down. + + Using ‘--color --graph’ is even slower. Magit uses code that is part +of Emacs to turn control characters into faces. That code is pretty +slow and this is quite noticeable when showing a log with many branches +and merges. For that reason ‘--color’ is not enabled by default +anymore. Consider leaving it at that. + +Diff Performance +................ + +If diffs are slow, then consider turning off some optional diff features +by setting all or some of the following variables to ‘nil’: +‘magit-diff-highlight-indentation’, ‘magit-diff-highlight-trailing’, +‘magit-diff-paint-whitespace’, ‘magit-diff-highlight-hunk-body’, and +‘magit-diff-refine-hunk’. + + When showing a commit instead of some arbitrary diff, then some +additional information is displayed. Calculating this information can +be quite expensive given certain circumstances. If looking at a commit +using ‘magit-revision-mode’ takes considerably more time than looking at +the same commit in ‘magit-diff-mode’, then consider setting +‘magit-revision-insert-related-refs’ to ‘nil’. + + When you are often confronted with diffs that contain deleted files, +then you might want to enable the ‘--irreversible-delete’ argument. If +you do that then diffs still show that a file was deleted but without +also showing the complete deleted content of the file. This argument is +not available by default, see *note (transient)Enabling and Disabling +Suffixes::. Once you have done that you should enable it and save that +setting, see *note (transient)Saving Values::. You should do this in +both the diff (‘d’) and the diff refresh (‘D’) transient popups. + +Refs Buffer Performance +....................... + +When refreshing the "references buffer" is slow, then that’s usually +because several hundred refs are being displayed. The best way to +address that is to display fewer refs, obviously. + + If you are not, or only mildly, interested in seeing the list of +tags, then start by not displaying them: + + (remove-hook 'magit-refs-sections-hook 'magit-insert-tags) + + Then you should also make sure that the listed remote branches +actually all exist. You can do so by pruning branches which no longer +exist using ‘f-pa’. + +Committing Performance +...................... + +When you initiate a commit, then Magit by default automatically shows a +diff of the changes you are about to commit. For large commits this can +take a long time, which is especially distracting when you are +committing large amounts of generated data which you don’t actually +intend to inspect before committing. This behavior can be turned off +using: + + (remove-hook 'server-switch-hook 'magit-commit-diff) + (remove-hook 'with-editor-filter-visit-hook 'magit-commit-diff) + + Then you can type ‘C-c C-d’ to show the diff when you actually want +to see it, but only then. Alternatively you can leave the hook alone +and just type ‘C-g’ in those cases when it takes too long to generate +the diff. If you do that, then you will end up with a broken diff +buffer, but doing it this way has the advantage that you usually get to +see the diff, which is useful because it increases the odds that you +spot potential issues. + + +File: doc5khxAZ.info, Node: Microsoft Windows Performance, Next: MacOS Performance, Up: Performance + +Microsoft Windows Performance +............................. + +In order to update the status buffer, ‘git’ has to be run a few dozen +times. That is problematic on Microsoft Windows, because that operating +system is exceptionally slow at starting processes. Sadly this is an +issue that can only be fixed by Microsoft itself, and they don’t appear +to be particularly interested in doing so. + + Beside the subprocess issue, there are also other Windows-specific +performance issues. Some of these have workarounds. The maintainers of +"Git for Windows" try to improve performance on Windows. Always use the +latest release in order to benefit from the latest performance tweaks. +Magit too tries to work around some Windows-specific issues. + + According to some sources, setting the following Git variables can +also help. + + git config --global core.preloadindex true # default since v2.1 + git config --global core.fscache true # default since v2.8 + git config --global gc.auto 256 + + You should also check whether an anti-virus program is affecting +performance. + + +File: doc5khxAZ.info, Node: MacOS Performance, Prev: Microsoft Windows Performance, Up: Performance + +MacOS Performance +................. + +Before Emacs 26.1 child processes were created using ‘fork’ on macOS. +That needlessly copied GUI resources, which is expensive. The result +was that forking took about 30 times as long on Darwin than on Linux, +and because Magit starts many ‘git’ processes that made quite a +difference. + + So make sure that you are using at least Emacs 26.1, in which case +the faster ‘vfork’ will be used. (The creation of child processes still +takes about twice as long on Darwin compared to Linux.) See (1) for +more information. + + Additionally, ‘git’ installed from a package manager like ‘brew’ or +‘nix’ seems to be slower than the native executable. Profile the ‘git’ +executable you’re running against the one at ‘/usr/bin/git’, and if you +notice a notable difference try using the latter as +‘magit-git-executable’. + + ---------- Footnotes ---------- + + (1) + + + +File: doc5khxAZ.info, Node: Global Bindings, Prev: Performance, Up: Essential Settings + +9.2.3 Global Bindings +--------------------- + +User Option: magit-define-global-key-bindings + This option controls which set of Magit key bindings, if any, may + be added to the global keymap, even before Magit is first used in + the current Emacs session. + + • If the value is ‘nil’, no bindings are added. + + • If ‘default’, maybe add: + + ‘C-x g’ ‘magit-status’ + ‘C-x M-g’ ‘magit-dispatch’ + ‘C-c M-g’ ‘magit-file-dispatch’ + + • If ‘recommended’, maybe add: + + ‘C-x g’ ‘magit-status’ + ‘C-c g’ ‘magit-dispatch’ + ‘C-c f’ ‘magit-file-dispatch’ + + These bindings are strongly recommended, but we cannot use + them by default, because the ‘C-c ’ namespace is + strictly reserved for bindings added by the user (see *note + (elisp)Key Binding Conventions::). + + The bindings in the chosen set may be added when ‘after-init-hook’ + is run. Each binding is added if, and only if, at that time no + other key is bound to the same command, and no other command is + bound to the same key. In other words we try to avoid adding + bindings that are unnecessary, as well as bindings that conflict + with other bindings. + + Adding these bindings is delayed until ‘after-init-hook’ is run to + allow users to set the variable anywhere in their init file + (without having to make sure to do so before ‘magit’ is loaded or + autoloaded) and to increase the likelihood that all the potentially + conflicting user bindings have already been added. + + To set this variable use either ‘setq’ or the Custom interface. Do + not use the function ‘customize-set-variable’ because doing that + would cause Magit to be loaded immediately, when that form is + evaluated (this differs from ‘custom-set-variables’, which doesn’t + load the libraries that define the customized variables). + + Setting this variable has no effect if ‘after-init-hook’ has + already been run. + + +File: doc5khxAZ.info, Node: Plumbing, Next: FAQ, Prev: Customizing, Up: Top + +10 Plumbing +*********** + +The following sections describe how to use several of Magit’s core +abstractions to extend Magit itself or implement a separate extension. + + A few of the low-level features used by Magit have been factored out +into separate libraries/packages, so that they can be used by other +packages, without having to depend on Magit. See *note +(with-editor)Top:: for information about ‘with-editor’. ‘transient’ +doesn’t have a manual yet. + + If you are trying to find an unused key that you can bind to a +command provided by your own Magit extension, then checkout +. + +* Menu: + +* Calling Git:: +* Section Plumbing:: +* Refreshing Buffers:: +* Conventions:: + + +File: doc5khxAZ.info, Node: Calling Git, Next: Section Plumbing, Up: Plumbing + +10.1 Calling Git +================ + +Magit provides many specialized functions for calling Git. All of these +functions are defined in either ‘magit-git.el’ or ‘magit-process.el’ and +have one of the prefixes ‘magit-run-’, ‘magit-call-’, ‘magit-start-’, or +‘magit-git-’ (which is also used for other things). + + All of these functions accept an indefinite number of arguments, +which are strings that specify command line arguments for Git (or in +some cases an arbitrary executable). These arguments are flattened +before being passed on to the executable; so instead of strings they can +also be lists of strings and arguments that are ‘nil’ are silently +dropped. Some of these functions also require a single mandatory +argument before these command line arguments. + + Roughly speaking, these functions run Git either to get some value or +for side-effects. The functions that return a value are useful to +collect the information necessary to populate a Magit buffer, while the +others are used to implement Magit commands. + + The functions in the value-only group always run synchronously, and +they never trigger a refresh. The function in the side-effect group can +be further divided into subgroups depending on whether they run Git +synchronously or asynchronously, and depending on whether they trigger a +refresh when the executable has finished. + +* Menu: + +* Getting a Value from Git:: +* Calling Git for Effect:: + + +File: doc5khxAZ.info, Node: Getting a Value from Git, Next: Calling Git for Effect, Up: Calling Git + +10.1.1 Getting a Value from Git +------------------------------- + +These functions run Git in order to get a value, an exit status, or +output. Of course you could also use them to run Git commands that have +side-effects, but that should be avoided. + +Function: magit-git-exit-code &rest args + Executes git with ARGS and returns its exit code. + +Function: magit-git-success &rest args + Executes git with ARGS and returns ‘t’ if the exit code is ‘0’, + ‘nil’ otherwise. + +Function: magit-git-failure &rest args + Executes git with ARGS and returns ‘t’ if the exit code is ‘1’, + ‘nil’ otherwise. + +Function: magit-git-true &rest args + Executes git with ARGS and returns ‘t’ if the first line printed by + git is the string "true", ‘nil’ otherwise. + +Function: magit-git-false &rest args + Executes git with ARGS and returns ‘t’ if the first line printed by + git is the string "false", ‘nil’ otherwise. + +Function: magit-git-insert &rest args + Executes git with ARGS and inserts its output at point. + +Function: magit-git-string &rest args + Executes git with ARGS and returns the first line of its output. + If there is no output or if it begins with a newline character, + then this returns ‘nil’. + +Function: magit-git-lines &rest args + Executes git with ARGS and returns its output as a list of lines. + Empty lines anywhere in the output are omitted. + +Function: magit-git-items &rest args + Executes git with ARGS and returns its null-separated output as a + list. Empty items anywhere in the output are omitted. + + If the value of option ‘magit-git-debug’ is non-nil and git exits + with a non-zero exit status, then warn about that in the echo area + and add a section containing git’s standard error in the current + repository’s process buffer. + +Function: magit-process-git destination &rest args + Calls Git synchronously in a separate process, returning its exit + code. DESTINATION specifies how to handle the output, like for + ‘call-process’, except that file handlers are supported. Enables + Cygwin’s "noglob" option during the call and ensures unix eol + conversion. + +Function: magit-process-file process &optional infile buffer display &rest args + Processes files synchronously in a separate process. Identical to + ‘process-file’ but temporarily enables Cygwin’s "noglob" option + during the call and ensures unix eol conversion. + + If an error occurs when using one of the above functions, then that +is usually due to a bug, i.e., using an argument which is not actually +supported. Such errors are usually not reported, but when they occur we +need to be able to debug them. + +User Option: magit-git-debug + Whether to report errors that occur when using ‘magit-git-insert’, + ‘magit-git-string’, ‘magit-git-lines’, or ‘magit-git-items’. This + does not actually raise an error. Instead a message is shown in + the echo area, and git’s standard error is insert into a new + section in the current repository’s process buffer. + +Function: magit-git-str &rest args + This is a variant of ‘magit-git-string’ that ignores the option + ‘magit-git-debug’. It is mainly intended to be used while handling + errors in functions that do respect that option. Using such a + function while handing an error could cause yet another error and + therefore lead to an infinite recursion. You probably won’t ever + need to use this function. + + +File: doc5khxAZ.info, Node: Calling Git for Effect, Prev: Getting a Value from Git, Up: Calling Git + +10.1.2 Calling Git for Effect +----------------------------- + +These functions are used to run git to produce some effect. Most Magit +commands that actually run git do so by using such a function. + + Because we do not need to consume git’s output when using these +functions, their output is instead logged into a per-repository buffer, +which can be shown using ‘$’ from a Magit buffer or ‘M-x magit-process’ +elsewhere. + + These functions can have an effect in two distinct ways. Firstly, +running git may change something, i.e., create or push a new commit. +Secondly, that change may require that Magit buffers are refreshed to +reflect the changed state of the repository. But refreshing isn’t +always desirable, so only some of these functions do perform such a +refresh after git has returned. + + Sometimes it is useful to run git asynchronously. For example, when +the user has just initiated a push, then there is no reason to make her +wait until that has completed. In other cases it makes sense to wait +for git to complete before letting the user do something else. For +example after staging a change it is useful to wait until after the +refresh because that also automatically moves to the next change. + +Function: magit-call-git &rest args + Calls git synchronously with ARGS. + +Function: magit-call-process program &rest args + Calls PROGRAM synchronously with ARGS. + +Function: magit-run-git &rest args + Calls git synchronously with ARGS and then refreshes. + +Function: magit-run-git-with-input &rest args + Calls git synchronously with ARGS and sends it the content of the + current buffer on standard input. + + If the current buffer’s ‘default-directory’ is on a remote + filesystem, this function actually runs git asynchronously. But + then it waits for the process to return, so the function itself is + synchronous. + +Function: magit-git &rest args + Calls git synchronously with ARGS for side-effects only. This + function does not refresh the buffer. + +Function: magit-git-wash washer &rest args + Execute Git with ARGS, inserting washed output at point. Actually + first insert the raw output at point. If there is no output call + ‘magit-cancel-section’. Otherwise temporarily narrow the buffer to + the inserted text, move to its beginning, and then call function + WASHER with ARGS as its sole argument. + + And now for the asynchronous variants. + +Function: magit-run-git-async &rest args + Start Git, prepare for refresh, and return the process object. + ARGS is flattened and then used as arguments to Git. + + Display the command line arguments in the echo area. + + After Git returns some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + Unmodified buffers visiting files that are tracked in the current + repository are reverted if ‘magit-revert-buffers’ is non-nil. + +Function: magit-run-git-with-editor &rest args + Export GIT_EDITOR and start Git. Also prepare for refresh and + return the process object. ARGS is flattened and then used as + arguments to Git. + + Display the command line arguments in the echo area. + + After Git returns some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + +Function: magit-start-git input &rest args + Start Git, prepare for refresh, and return the process object. + + If INPUT is non-nil, it has to be a buffer or the name of an + existing buffer. The buffer content becomes the processes standard + input. + + Option ‘magit-git-executable’ specifies the Git executable and + option ‘magit-git-global-arguments’ specifies constant arguments. + The remaining arguments ARGS specify arguments to Git. They are + flattened before use. + + After Git returns, some buffers are refreshed: the buffer that was + current when this function was called (if it is a Magit buffer and + still alive), as well as the respective Magit status buffer. + Unmodified buffers visiting files that are tracked in the current + repository are reverted if ‘magit-revert-buffers’ is non-nil. + +Function: magit-start-process &rest args + Start PROGRAM, prepare for refresh, and return the process object. + + If optional argument INPUT is non-nil, it has to be a buffer or the + name of an existing buffer. The buffer content becomes the + processes standard input. + + The process is started using ‘start-file-process’ and then setup to + use the sentinel ‘magit-process-sentinel’ and the filter + ‘magit-process-filter’. Information required by these functions is + stored in the process object. When this function returns the + process has not started to run yet so it is possible to override + the sentinel and filter. + + After the process returns, ‘magit-process-sentinel’ refreshes the + buffer that was current when ‘magit-start-process’ was called (if + it is a Magit buffer and still alive), as well as the respective + Magit status buffer. Unmodified buffers visiting files that are + tracked in the current repository are reverted if + ‘magit-revert-buffers’ is non-nil. + +Variable: magit-this-process + The child process which is about to start. This can be used to + change the filter and sentinel. + +Variable: magit-process-raise-error + When this is non-nil, then ‘magit-process-sentinel’ raises an error + if git exits with a non-zero exit status. For debugging purposes. + + +File: doc5khxAZ.info, Node: Section Plumbing, Next: Refreshing Buffers, Prev: Calling Git, Up: Plumbing + +10.2 Section Plumbing +===================== + +* Menu: + +* Creating Sections:: +* Section Selection:: +* Matching Sections:: + + +File: doc5khxAZ.info, Node: Creating Sections, Next: Section Selection, Up: Section Plumbing + +10.2.1 Creating Sections +------------------------ + +Macro: magit-insert-section &rest args + Insert a section at point. + + TYPE is the section type, a symbol. Many commands that act on the + current section behave differently depending on that type. Also if + a variable ‘magit-TYPE-section-map’ exists, then use that as the + text-property ‘keymap’ of all text belonging to the section (but + this may be overwritten in subsections). TYPE can also have the + form ‘(eval FORM)’ in which case FORM is evaluated at runtime. + + Optional VALUE is the value of the section, usually a string that + is required when acting on the section. + + When optional HIDE is non-nil collapse the section body by default, + i.e., when first creating the section, but not when refreshing the + buffer. Otherwise, expand it by default. This can be overwritten + using ‘magit-section-set-visibility-hook’. When a section is + recreated during a refresh, then the visibility of predecessor is + inherited and HIDE is ignored (but the hook is still honored). + + BODY is any number of forms that actually insert the section’s + heading and body. Optional NAME, if specified, has to be a symbol, + which is then bound to the struct of the section being inserted. + + Before BODY is evaluated the ‘start’ of the section object is set + to the value of ‘point’ and after BODY was evaluated its ‘end’ is + set to the new value of ‘point’; BODY is responsible for moving + ‘point’ forward. + + If it turns out inside BODY that the section is empty, then + ‘magit-cancel-section’ can be used to abort and remove all traces + of the partially inserted section. This can happen when creating a + section by washing Git’s output and Git didn’t actually output + anything this time around. + +Function: magit-insert-heading &rest args + Insert the heading for the section currently being inserted. + + This function should only be used inside ‘magit-insert-section’. + + When called without any arguments, then just set the ‘content’ slot + of the object representing the section being inserted to a marker + at ‘point’. The section should only contain a single line when + this function is used like this. + + When called with arguments ARGS, which have to be strings, then + insert those strings at point. The section should not contain any + text before this happens and afterwards it should again only + contain a single line. If the ‘face’ property is set anywhere + inside any of these strings, then insert all of them unchanged. + Otherwise use the ‘magit-section-heading’ face for all inserted + text. + + The ‘content’ property of the section struct is the end of the + heading (which lasts from ‘start’ to ‘content’) and the beginning + of the body (which lasts from ‘content’ to ‘end’). If the value of + ‘content’ is nil, then the section has no heading and its body + cannot be collapsed. If a section does have a heading then its + height must be exactly one line, including a trailing newline + character. This isn’t enforced; you are responsible for getting it + right. The only exception is that this function does insert a + newline character if necessary. + +Function: magit-cancel-section + Cancel the section currently being inserted. This exits the + innermost call to ‘magit-insert-section’ and removes all traces of + what has already happened inside that call. + +Function: magit-define-section-jumper sym title &optional value + Define an interactive function to go to section SYM. TITLE is the + displayed title of the section. + + +File: doc5khxAZ.info, Node: Section Selection, Next: Matching Sections, Prev: Creating Sections, Up: Section Plumbing + +10.2.2 Section Selection +------------------------ + +Function: magit-current-section + Return the section at point. + +Function: magit-region-sections &optional condition multiple + Return a list of the selected sections. + + When the region is active and constitutes a valid section + selection, then return a list of all selected sections. This is + the case when the region begins in the heading of a section and + ends in the heading of the same section or in that of a sibling + section. If optional MULTIPLE is non-nil, then the region cannot + begin and end in the same section. + + When the selection is not valid, then return nil. In this case, + most commands that can act on the selected sections will instead + act on the section at point. + + When the region looks like it would in any other buffer then the + selection is invalid. When the selection is valid then the region + uses the ‘magit-section-highlight’ face. This does not apply to + diffs where things get a bit more complicated, but even here if the + region looks like it usually does, then that’s not a valid + selection as far as this function is concerned. + + If optional CONDITION is non-nil, then the selection not only has + to be valid; all selected sections additionally have to match + CONDITION, or nil is returned. See ‘magit-section-match’ for the + forms CONDITION can take. + +Function: magit-region-values &optional condition multiple + Return a list of the values of the selected sections. + + Return the values that themselves would be returned by + ‘magit-region-sections’ (which see). + + +File: doc5khxAZ.info, Node: Matching Sections, Prev: Section Selection, Up: Section Plumbing + +10.2.3 Matching Sections +------------------------ + +Key: M-x magit-describe-section-briefly + Show information about the section at point. This command is + intended for debugging purposes. + +Function: magit-section-ident section + Return an unique identifier for SECTION. The return value has the + form ‘((TYPE . VALUE)...)’. + +Function: magit-get-section ident &optional root + Return the section identified by IDENT. IDENT has to be a list as + returned by ‘magit-section-ident’. + +Function: magit-section-match condition &optional section + Return ‘t’ if SECTION matches CONDITION. SECTION defaults to the + section at point. If SECTION is not specified and there also is no + section at point, then return ‘nil’. + + CONDITION can take the following forms: + • ‘(CONDITION...)’ + + matches if any of the CONDITIONs matches. + + • ‘[CLASS...]’ + + matches if the section’s class is the same as the first CLASS + or a subclass of that; the section’s parent class matches the + second CLASS; and so on. + + • ‘[* CLASS...]’ + + matches sections that match ‘[CLASS...]’ and also recursively + all their child sections. + + • ‘CLASS’ + + matches if the section’s class is the same as CLASS or a + subclass of that; regardless of the classes of the parent + sections. + + Each CLASS should be a class symbol, identifying a class that + derives from ‘magit-section’. For backward compatibility CLASS can + also be a "type symbol". A section matches such a symbol if the + value of its ‘type’ slot is ‘eq’. If a type symbol has an entry in + ‘magit--section-type-alist’, then a section also matches that type + if its class is a subclass of the class that corresponds to the + type as per that alist. + + Note that it is not necessary to specify the complete section + lineage as printed by ‘magit-describe-section-briefly’, unless of + course you want to be that precise. + +Function: magit-section-value-if condition &optional section + If the section at point matches CONDITION, then return its value. + + If optional SECTION is non-nil then test whether that matches + instead. If there is no section at point and SECTION is nil, then + return nil. If the section does not match, then return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + +Function: magit-section-case &rest clauses + Choose among clauses on the type of the section at point. + + Each clause looks like (CONDITION BODY...). The type of the + section is compared against each CONDITION; the BODY forms of the + first match are evaluated sequentially and the value of the last + form is returned. Inside BODY the symbol ‘it’ is bound to the + section at point. If no clause succeeds or if there is no section + at point return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + Additionally a CONDITION of t is allowed in the final clause and + matches if no other CONDITION match, even if there is no section at + point. + +Variable: magit-root-section + The root section in the current buffer. All other sections are + descendants of this section. The value of this variable is set by + ‘magit-insert-section’ and you should never modify it. + + For diff related sections a few additional tools exist. + +Function: magit-diff-type &optional section + Return the diff type of SECTION. + + The returned type is one of the symbols ‘staged’, ‘unstaged’, + ‘committed’, or ‘undefined’. This type serves a similar purpose as + the general type common to all sections (which is stored in the + ‘type’ slot of the corresponding ‘magit-section’ struct) but takes + additional information into account. When the SECTION isn’t + related to diffs and the buffer containing it also isn’t a + diff-only buffer, then return nil. + + Currently the type can also be one of ‘tracked’ and ‘untracked’, + but these values are not handled explicitly in every place they + should be. A possible fix could be to just return nil here. + + The section has to be a ‘diff’ or ‘hunk’ section, or a section + whose children are of type ‘diff’. If optional SECTION is nil, + return the diff type for the current section. In buffers whose + major mode is ‘magit-diff-mode’ SECTION is ignored and the type is + determined using other means. In ‘magit-revision-mode’ buffers the + type is always ‘committed’. + +Function: magit-diff-scope &optional section strict + Return the diff scope of SECTION or the selected section(s). + + A diff’s "scope" describes what part of a diff is selected, it is a + symbol, one of ‘region’, ‘hunk’, ‘hunks’, ‘file’, ‘files’, or + ‘list’. Do not confuse this with the diff "type", as returned by + ‘magit-diff-type’. + + If optional SECTION is non-nil, then return the scope of that, + ignoring the sections selected by the region. Otherwise return the + scope of the current section, or if the region is active and + selects a valid group of diff related sections, the type of these + sections, i.e., ‘hunks’ or ‘files’. If SECTION (or if the current + section that is nil) is a ‘hunk’ section and the region starts and + ends inside the body of a that section, then the type is ‘region’. + + If optional STRICT is non-nil then return nil if the diff type of + the section at point is ‘untracked’ or the section at point is not + actually a ‘diff’ but a ‘diffstat’ section. + + +File: doc5khxAZ.info, Node: Refreshing Buffers, Next: Conventions, Prev: Section Plumbing, Up: Plumbing + +10.3 Refreshing Buffers +======================= + +All commands that create a new Magit buffer or change what is being +displayed in an existing buffer do so by calling ‘magit-mode-setup’. +Among other things, that function sets the buffer local values of +‘default-directory’ (to the top-level of the repository), +‘magit-refresh-function’, and ‘magit-refresh-args’. + + Buffers are refreshed by calling the function that is the local value +of ‘magit-refresh-function’ (a function named ‘magit-*-refresh-buffer’, +where ‘*’ may be something like ‘diff’) with the value of +‘magit-refresh-args’ as arguments. + +Macro: magit-mode-setup buffer switch-func mode refresh-func &optional refresh-args + This function displays and selects BUFFER, turns on MODE, and + refreshes a first time. + + This function displays and optionally selects BUFFER by calling + ‘magit-mode-display-buffer’ with BUFFER, MODE and SWITCH-FUNC as + arguments. Then it sets the local value of + ‘magit-refresh-function’ to REFRESH-FUNC and that of + ‘magit-refresh-args’ to REFRESH-ARGS. Finally it creates the + buffer content by calling REFRESH-FUNC with REFRESH-ARGS as + arguments. + + All arguments are evaluated before switching to BUFFER. + +Function: magit-mode-display-buffer buffer mode &optional switch-function + This function display BUFFER in some window and select it. BUFFER + may be a buffer or a string, the name of a buffer. The buffer is + returned. + + Unless BUFFER is already displayed in the selected frame, store the + previous window configuration as a buffer local value, so that it + can later be restored by ‘magit-mode-bury-buffer’. + + The buffer is displayed and selected using SWITCH-FUNCTION. If + that is ‘nil’ then ‘pop-to-buffer’ is used if the current buffer’s + major mode derives from ‘magit-mode’. Otherwise ‘switch-to-buffer’ + is used. + +Variable: magit-refresh-function + The value of this buffer-local variable is the function used to + refresh the current buffer. It is called with ‘magit-refresh-args’ + as arguments. + +Variable: magit-refresh-args + The list of arguments used by ‘magit-refresh-function’ to refresh + the current buffer. ‘magit-refresh-function’ is called with these + arguments. + + The value is usually set using ‘magit-mode-setup’, but in some + cases it’s also useful to provide commands that can change the + value. For example, the ‘magit-diff-refresh’ transient can be used + to change any of the arguments used to display the diff, without + having to specify again which differences should be shown, but + ‘magit-diff-more-context’, ‘magit-diff-less-context’ and + ‘magit-diff-default-context’ change just the ‘-U’ argument. In + both case this is done by changing the value of this variable and + then calling this ‘magit-refresh-function’. + + +File: doc5khxAZ.info, Node: Conventions, Prev: Refreshing Buffers, Up: Plumbing + +10.4 Conventions +================ + +Also see *note Completion and Confirmation::. + +* Menu: + +* Theming Faces:: + + +File: doc5khxAZ.info, Node: Theming Faces, Up: Conventions + +10.4.1 Theming Faces +-------------------- + +The default theme uses blue for local branches, green for remote +branches, and goldenrod (brownish yellow) for tags. When creating a new +theme, you should probably follow that example. If your theme already +uses other colors, then stick to that. + + In older releases these reference faces used to have a background +color and a box around them. The basic default faces no longer do so, +to make Magit buffers much less noisy, and you should follow that +example at least with regards to boxes. (Boxes were used in the past to +work around a conflict between the highlighting overlay and text +property backgrounds. That’s no longer necessary because highlighting +no longer causes other background colors to disappear.) Alternatively +you can keep the background color and/or box, but then have to take +special care to adjust ‘magit-branch-current’ accordingly. By default +it looks mostly like ‘magit-branch-local’, but with a box (by default +the former is the only face that uses a box, exactly so that it sticks +out). If the former also uses a box, then you have to make sure that it +differs in some other way from the latter. + + The most difficult faces to theme are those related to diffs, +headings, highlighting, and the region. There are faces that fall into +all four groups - expect to spend some time getting this right. + + The ‘region’ face in the default theme, in both the light and dark +variants, as well as in many other themes, distributed with Emacs or by +third-parties, is very ugly. It is common to use a background color +that really sticks out, which is ugly but if that were the only problem +then it would be acceptable. Unfortunately many themes also set the +foreground color, which ensures that all text within the region is +readable. Without doing that there might be cases where some foreground +color is too close to the region background color to still be readable. +But it also means that text within the region loses all syntax +highlighting. + + I consider the work that went into getting the ‘region’ face right to +be a good indicator for the general quality of a theme. My +recommendation for the ‘region’ face is this: use a background color +slightly different from the background color of the ‘default’ face, and +do not set the foreground color at all. So for a light theme you might +use a light (possibly tinted) gray as the background color of ‘default’ +and a somewhat darker gray for the background of ‘region’. That should +usually be enough to not collide with the foreground color of any other +face. But if some other faces also set a light gray as background +color, then you should also make sure it doesn’t collide with those (in +some cases it might be acceptable though). + + Magit only uses the ‘region’ face when the region is "invalid" by its +own definition. In a Magit buffer the region is used to either select +multiple sibling sections, so that commands which support it act on all +of these sections instead of just the current section, or to select +lines within a single hunk section. In all other cases, the section is +considered invalid and Magit won’t act on it. But such invalid sections +happen, either because the user has not moved point enough yet to make +it valid or because she wants to use a non-magit command to act on the +region, e.g., ‘kill-region’. + + So using the regular ‘region’ face for invalid sections is a feature. +It tells the user that Magit won’t be able to act on it. It’s +acceptable if that face looks a bit odd and even (but less so) if it +collides with the background colors of section headings and other things +that have a background color. + + Magit highlights the current section. If a section has subsections, +then all of them are highlighted. This is done using faces that have +"highlight" in their names. For most sections, +‘magit-section-highlight’ is used for both the body and the heading. +Like the ‘region’ face, it should only set the background color to +something similar to that of ‘default’. The highlight background color +must be different from both the ‘region’ background color and the +‘default’ background color. + + For diff related sections Magit uses various faces to highlight +different parts of the selected section(s). Note that hunk headings, +unlike all other section headings, by default have a background color, +because it is useful to have very visible separators between hunks. +That face ‘magit-diff-hunk-heading’, should be different from both +‘magit-diff-hunk-heading-highlight’ and ‘magit-section-highlight’, as +well as from ‘magit-diff-context’ and ‘magit-diff-context-highlight’. +By default we do that by changing the foreground color. Changing the +background color would lead to complications, and there are already +enough we cannot get around. (Also note that it is generally a good +idea for section headings to always be bold, but only for sections that +have subsections). + + When there is a valid region selecting diff-related sibling sections, +i.e., multiple files or hunks, then the bodies of all these sections use +the respective highlight faces, but additionally the headings instead +use one of the faces ‘magit-diff-file-heading-selection’ or +‘magit-diff-hunk-heading-selection’. These faces have to be different +from the regular highlight variants to provide explicit visual +indication that the region is active. + + When theming diff related faces, start by setting the option +‘magit-diff-refine-hunk’ to ‘all’. You might personally prefer to only +refine the current hunk or not use hunk refinement at all, but some of +the users of your theme want all hunks to be refined, so you have to +cater to that. + + (Also turn on ‘magit-diff-highlight-indentation’, +‘magit-diff-highlight-trailing’, and ‘magit-diff-paint-whitespace’; and +insert some whitespace errors into the code you use for testing.) + + For added lines you have to adjust three faces: ‘magit-diff-added’, +‘magit-diff-added-highlight’, and ‘diff-refined-added’. Make sure that +the latter works well with both of the former, as well as ‘smerge-other’ +and ‘diff-added’. Then do the same for the removed lines, context +lines, lines added by us, and lines added by them. Also make sure the +respective added, removed, and context faces use approximately the same +saturation for both the highlighted and unhighlighted variants. Also +make sure the file and diff headings work nicely with context lines +(e.g., make them look different). Line faces should set both the +foreground and the background color. For example, for added lines use +two different greens. + + It’s best if the foreground color of both the highlighted and the +unhighlighted variants are the same, so you will need to have to find a +color that works well on the highlight and unhighlighted background, the +refine background, and the highlight context background. When there is +an hunk internal region, then the added- and removed-lines background +color is used only within that region. Outside the region the +highlighted context background color is used. This makes it easier to +see what is being staged. With an hunk internal region the hunk heading +is shown using ‘magit-diff-hunk-heading-selection’, and so are the thin +lines that are added around the lines that fall within the region. The +background color of that has to be distinct enough from the various +other involved background colors. + + Nobody said this would be easy. If your theme restricts itself to a +certain set of colors, then you should make an exception here. +Otherwise it would be impossible to make the diffs look good in each and +every variation. Actually you might want to just stick to the default +definitions for these faces. You have been warned. Also please note +that if you do not get this right, this will in some cases look to users +like bugs in Magit - so please do it right or not at all. + + +File: doc5khxAZ.info, Node: FAQ, Next: Debugging Tools, Prev: Plumbing, Up: Top + +Appendix A FAQ +************** + +The next two nodes lists frequently asked questions. For a list of +frequently *and recently* asked questions, i.e., questions that haven’t +made it into the manual yet, see +. + + Please also see *note Debugging Tools::. + +* Menu: + +* FAQ - How to ...?:: +* FAQ - Issues and Errors:: + + +File: doc5khxAZ.info, Node: FAQ - How to ...?, Next: FAQ - Issues and Errors, Up: FAQ + +A.1 FAQ - How to ...? +===================== + +* Menu: + +* How to pronounce Magit?:: +* How to show git's output?:: +* How to install the gitman info manual?:: +* How to show diffs for gpg-encrypted files?:: +* How does branching and pushing work?:: +* Should I disable VC?:: + + +File: doc5khxAZ.info, Node: How to pronounce Magit?, Next: How to show git's output?, Up: FAQ - How to ...? + +A.1.1 How to pronounce Magit? +----------------------------- + +Either ‘mu[m's] git’ or ‘magi{c => t}’ is fine. + + The slogan is "It’s Magit! The magical Git client", so it makes +sense to pronounce Magit like magic, while taking into account that C +and T do not sound the same. + + The German "Magie" is not pronounced the same as the English "magic", +so if you speak German, then you can use the above rationale to justify +using the former pronunciation; ‘Mag{ie => it}’. + + You can also choose to use the former pronunciation just because you +like it better. + + Also see . Also see +. + + +File: doc5khxAZ.info, Node: How to show git's output?, Next: How to install the gitman info manual?, Prev: How to pronounce Magit?, Up: FAQ - How to ...? + +A.1.2 How to show git’s output? +------------------------------- + +To show the output of recently run git commands, press ‘$’ (or, if that +isn’t available, use ‘M-x magit-process-buffer’). This shows a buffer +containing a section per git invocation; as always press ‘TAB’ to expand +or collapse them. + + By default, git’s output is only inserted into the process buffer if +it is run for side-effects. When the output is consumed in some way, +also inserting it into the process buffer would be too expensive. For +debugging purposes, it’s possible to do so anyway, using ‘M-x +magit-toggle-git-debug’. + + +File: doc5khxAZ.info, Node: How to install the gitman info manual?, Next: How to show diffs for gpg-encrypted files?, Prev: How to show git's output?, Up: FAQ - How to ...? + +A.1.3 How to install the gitman info manual? +-------------------------------------------- + +Git’s manpages can be exported as an info manual called ‘gitman’. +Magit’s own info manual links to nodes in that manual instead of the +actual manpages, simply because Info doesn’t support linking to +manpages. + + Unfortunately some distributions do not install the ‘gitman’ manual +by default and you would have to install a separate documentation +package to get it. + + Magit patches info, adding the ability to visit links to the ‘gitman’ +info manual, by instead viewing the respective manpage. If you prefer +that approach, then set the value of ‘magit-view-git-manual-method’ to +one of the supported Emacs packages ‘man’ or ‘woman’, e.g.: + + (setq magit-view-git-manual-method 'man) + + +File: doc5khxAZ.info, Node: How to show diffs for gpg-encrypted files?, Next: How does branching and pushing work?, Prev: How to install the gitman info manual?, Up: FAQ - How to ...? + +A.1.4 How to show diffs for gpg-encrypted files? +------------------------------------------------ + +Git supports showing diffs for encrypted files, but has to be told to do +so. Since Magit just uses Git to get the diffs, configuring Git also +affects the diffs displayed inside Magit. + + git config --global diff.gpg.textconv "gpg --no-tty --decrypt" + echo "*.gpg filter=gpg diff=gpg" > .gitattributes + + +File: doc5khxAZ.info, Node: How does branching and pushing work?, Next: Should I disable VC?, Prev: How to show diffs for gpg-encrypted files?, Up: FAQ - How to ...? + +A.1.5 How does branching and pushing work? +------------------------------------------ + +Please see *note Branching:: and + + + +File: doc5khxAZ.info, Node: Should I disable VC?, Prev: How does branching and pushing work?, Up: FAQ - How to ...? + +A.1.6 Should I disable VC? +-------------------------- + +If you don’t use VC (the built-in version control interface) then you +might be tempted to disable it, not least because we used to recommend +that you do that. + + We no longer recommend that you disable VC. Doing so would break +useful third-party packages (such as ‘diff-hl’), which depend on VC +being enabled. + + If you choose to disable VC anyway, then you can do so by changing +the value of ‘vc-handled-backends’. + + +File: doc5khxAZ.info, Node: FAQ - Issues and Errors, Prev: FAQ - How to ...?, Up: FAQ + +A.2 FAQ - Issues and Errors +=========================== + +* Menu: + +* Magit is slow:: +* I changed several thousand files at once and now Magit is unusable:: +* I am having problems committing:: +* I am using MS Windows and cannot push with Magit:: +* I am using macOS and SOMETHING works in shell, but not in Magit: I am using macOS and SOMETHING works in shell but not in Magit. +* Expanding a file to show the diff causes it to disappear:: +* Point is wrong in the COMMIT_EDITMSG buffer:: +* The mode-line information isn't always up-to-date:: +* A branch and tag sharing the same name breaks SOMETHING:: +* My Git hooks work on the command-line but not inside Magit:: +* git-commit-mode isn't used when committing from the command-line:: +* Point ends up inside invisible text when jumping to a file-visiting buffer:: +* I am no longer able to save popup defaults:: + + +File: doc5khxAZ.info, Node: Magit is slow, Next: I changed several thousand files at once and now Magit is unusable, Up: FAQ - Issues and Errors + +A.2.1 Magit is slow +------------------- + +See *note Performance:: and *note I changed several thousand files at +once and now Magit is unusable::. + + +File: doc5khxAZ.info, Node: I changed several thousand files at once and now Magit is unusable, Next: I am having problems committing, Prev: Magit is slow, Up: FAQ - Issues and Errors + +A.2.2 I changed several thousand files at once and now Magit is unusable +------------------------------------------------------------------------ + +Magit is currently not expected to work well under such conditions. It +sure would be nice if it did. Reaching satisfactory performance under +such conditions will require some heavy refactoring. This is no small +task but I hope to eventually find the time to make it happen. + + But for now we recommend you use the command line to complete this +one commit. Also see *note Performance::. + + +File: doc5khxAZ.info, Node: I am having problems committing, Next: I am using MS Windows and cannot push with Magit, Prev: I changed several thousand files at once and now Magit is unusable, Up: FAQ - Issues and Errors + +A.2.3 I am having problems committing +------------------------------------- + +That likely means that Magit is having problems finding an appropriate +‘emacsclient’ executable. See *note (with-editor)Configuring +With-Editor:: and *note (with-editor)Debugging::. + + +File: doc5khxAZ.info, Node: I am using MS Windows and cannot push with Magit, Next: I am using macOS and SOMETHING works in shell but not in Magit, Prev: I am having problems committing, Up: FAQ - Issues and Errors + +A.2.4 I am using MS Windows and cannot push with Magit +------------------------------------------------------ + +It’s almost certain that Magit is only incidental to this issue. It is +much more likely that this is a configuration issue, even if you can +push on the command line. + + Detailed setup instructions can be found at +. + + +File: doc5khxAZ.info, Node: I am using macOS and SOMETHING works in shell but not in Magit, Next: Expanding a file to show the diff causes it to disappear, Prev: I am using MS Windows and cannot push with Magit, Up: FAQ - Issues and Errors + +A.2.5 I am using macOS and SOMETHING works in shell, but not in Magit +--------------------------------------------------------------------- + +This usually occurs because Emacs doesn’t have the same environment +variables as your shell. Try installing and configuring +. By default it +synchronizes ‘$PATH’, which helps Magit find the same ‘git’ as the one +you are using on the shell. + + If SOMETHING is "passphrase caching with gpg-agent for commit and/or +tag signing", then you’ll also need to synchronize ‘$GPG_AGENT_INFO’. + + +File: doc5khxAZ.info, Node: Expanding a file to show the diff causes it to disappear, Next: Point is wrong in the COMMIT_EDITMSG buffer, Prev: I am using macOS and SOMETHING works in shell but not in Magit, Up: FAQ - Issues and Errors + +A.2.6 Expanding a file to show the diff causes it to disappear +-------------------------------------------------------------- + +This is probably caused by a customization of a ‘diff.*’ Git variable. +You probably set that variable for a reason, and should therefore only +undo that setting in Magit by customizing ‘magit-git-global-arguments’. + + +File: doc5khxAZ.info, Node: Point is wrong in the COMMIT_EDITMSG buffer, Next: The mode-line information isn't always up-to-date, Prev: Expanding a file to show the diff causes it to disappear, Up: FAQ - Issues and Errors + +A.2.7 Point is wrong in the ‘COMMIT_EDITMSG’ buffer +--------------------------------------------------- + +Neither Magit nor ‘git-commit.el’ fiddle with point in the buffer used +to write commit messages, so something else must be doing it. + + You have probably globally enabled a mode, which restores point in +file-visiting buffers. It might be a bit surprising, but when you write +a commit message, then you are actually editing a file. + + So you have to figure out which package is doing it. ‘saveplace’, +‘pointback’, and ‘session’ are likely candidates. These snippets might +help: + + (setq session-name-disable-regexp "\\(?:\\`'\\.git/[A-Z_]+\\'\\)") + + (with-eval-after-load 'pointback + (lambda () + (when (or git-commit-mode git-rebase-mode) + (pointback-mode -1)))) + + +File: doc5khxAZ.info, Node: The mode-line information isn't always up-to-date, Next: A branch and tag sharing the same name breaks SOMETHING, Prev: Point is wrong in the COMMIT_EDITMSG buffer, Up: FAQ - Issues and Errors + +A.2.8 The mode-line information isn’t always up-to-date +------------------------------------------------------- + +Magit is not responsible for the version control information that is +being displayed in the mode-line and looks something like ‘Git-master’. +The built-in "Version Control" package, also known as "VC", updates that +information, and can be told to do so more often: + + (setq auto-revert-check-vc-info t) + + But doing so isn’t good for performance. For more (overly +optimistic) information see *note (emacs)VC Mode Line::. + + If you don’t really care about seeing this information in the +mode-line, but just don’t want to see _incorrect_ information, then +consider simply not displaying it in the mode-line: + + (setq-default mode-line-format + (delete '(vc-mode vc-mode) mode-line-format)) + + +File: doc5khxAZ.info, Node: A branch and tag sharing the same name breaks SOMETHING, Next: My Git hooks work on the command-line but not inside Magit, Prev: The mode-line information isn't always up-to-date, Up: FAQ - Issues and Errors + +A.2.9 A branch and tag sharing the same name breaks SOMETHING +------------------------------------------------------------- + +Or more generally, ambiguous refnames break SOMETHING. + + Magit assumes that refs are named non-ambiguously across the +"refs/heads/", "refs/tags/", and "refs/remotes/" namespaces (i.e., all +the names remain unique when those prefixes are stripped). We consider +ambiguous refnames unsupported and recommend that you use a +non-ambiguous naming scheme. However, if you do work with a repository +that has ambiguous refnames, please report any issues you encounter, so +that we can investigate whether there is a simple fix. + + +File: doc5khxAZ.info, Node: My Git hooks work on the command-line but not inside Magit, Next: git-commit-mode isn't used when committing from the command-line, Prev: A branch and tag sharing the same name breaks SOMETHING, Up: FAQ - Issues and Errors + +A.2.10 My Git hooks work on the command-line but not inside Magit +----------------------------------------------------------------- + +When Magit calls ‘git’ it adds a few global arguments including +‘--literal-pathspecs’ and the ‘git’ process started by Magit then passes +that setting on to other ‘git’ process it starts itself. It does so by +setting the environment variable ‘GIT_LITERAL_PATHSPECS’, not by calling +subprocesses with the ‘--literal-pathspecs’ argument. You can therefore +override this setting in hook scripts using ‘unset +GIT_LITERAL_PATHSPECS’. + + +File: doc5khxAZ.info, Node: git-commit-mode isn't used when committing from the command-line, Next: Point ends up inside invisible text when jumping to a file-visiting buffer, Prev: My Git hooks work on the command-line but not inside Magit, Up: FAQ - Issues and Errors + +A.2.11 ‘git-commit-mode’ isn’t used when committing from the command-line +------------------------------------------------------------------------- + +The reason for this is that ‘git-commit.el’ has not been loaded yet +and/or that the server has not been started yet. These things have +always already been taken care of when you commit from Magit because in +order to do so, Magit has to be loaded and doing that involves loading +‘git-commit’ and starting the server. + + If you want to commit from the command-line, then you have to take +care of these things yourself. Your ‘init.el’ file should contain: + + (require 'git-commit) + (server-mode) + + Instead of ‘(require ’git-commit)‘ you may also use: + + (load "/path/to/magit-autoloads.el") + + You might want to do that because loading ‘git-commit’ causes large +parts of Magit to be loaded. + + There are also some variations of ‘(server-mode)’ that you might want +to try. Personally I use: + + (use-package server + :config (or (server-running-p) (server-mode))) + + Now you can use: + + $ emacs& + $ EDITOR=emacsclient git commit + + However you cannot use: + + $ killall emacs + $ EDITOR="emacsclient --alternate-editor emacs" git commit + + This will actually end up using ‘emacs’, not ‘emacsclient’. If you +do this, then you can still edit the commit message but +‘git-commit-mode’ won’t be used and you have to exit ‘emacs’ to finish +the process. + + Tautology ahead. If you want to be able to use ‘emacsclient’ to +connect to a running ‘emacs’ instance, even though no ‘emacs’ instance +is running, then you cannot use ‘emacsclient’ directly. + + Instead you have to create a script that does something like this: + + Try to use ‘emacsclient’ (without using ‘--alternate-editor’). If +that succeeds, do nothing else. Otherwise start ‘emacs &’ (and +‘init.el’ must call ‘server-start’) and try to use ‘emacsclient’ again. + + +File: doc5khxAZ.info, Node: Point ends up inside invisible text when jumping to a file-visiting buffer, Next: I am no longer able to save popup defaults, Prev: git-commit-mode isn't used when committing from the command-line, Up: FAQ - Issues and Errors + +A.2.12 Point ends up inside invisible text when jumping to a file-visiting buffer +--------------------------------------------------------------------------------- + +This can happen when you type ‘RET’ on a hunk to visit the respective +file at the respective position. One solution to this problem is to use +‘global-reveal-mode’. It makes sure that text around point is always +visible. If that is too drastic for your taste, then you may instead +use ‘magit-diff-visit-file-hook’ to reveal the text, possibly using +‘reveal-post-command’ or for Org buffers ‘org-reveal’. + + +File: doc5khxAZ.info, Node: I am no longer able to save popup defaults, Prev: Point ends up inside invisible text when jumping to a file-visiting buffer, Up: FAQ - Issues and Errors + +A.2.13 I am no longer able to save popup defaults +------------------------------------------------- + +Magit used to use Magit-Popup to implement the transient popup menus. +Now it used Transient instead, which is Magit-Popup’s successor. + + In the older Magit-Popup menus, it was possible to save user settings +(e.g., setting the gpg signing key for commits) by using ‘C-c C-c’ in +the popup buffer. This would dismiss the popup, but save the settings +as the defaults for future popups. + + When switching to Transient menus, this functionality is now +available via ‘C-x C-s’ instead; the ‘C-x’ prefix has other options as +well when using Transient, which will be displayed when it is typed. +See +for more details. + + +File: doc5khxAZ.info, Node: Debugging Tools, Next: Keystroke Index, Prev: FAQ, Up: Top + +B Debugging Tools +***************** + +Magit and its dependencies provide a few debugging tools, and we +appreciate it very much if you use those tools before reporting an +issue. Please include all relevant output when reporting an issue. + +Key: M-x magit-version + This command shows the currently used versions of Magit, Git, and + Emacs in the echo area. Non-interactively this just returns the + Magit version. + +Key: M-x magit-emacs-Q-command + This command shows a debugging shell command in the echo area and + adds it to the kill ring. Paste that command into a shell and run + it. + + This shell command starts ‘emacs’ with only ‘magit’ and its + dependencies loaded. Neither your configuration nor other + installed packages are loaded. This makes it easier to determine + whether some issue lays with Magit or something else. + + If you run Magit from its Git repository, then you should be able + to use ‘make emacs-Q’ instead of the output of this command. + +Key: M-x magit-toggle-git-debug + This command toggles whether additional git errors are reported. + + Magit basically calls git for one of these two reasons: for + side-effects or to do something with its standard output. + + When git is run for side-effects then its output, including error + messages, go into the process buffer which is shown when using ‘$’. + + When git’s output is consumed in some way, then it would be too + expensive to also insert it into this buffer, but with this command + that can be enabled temporarily. In that case, if git returns with + a non-zero exit status, then at least its standard error is + inserted into this buffer. + + Also note that just because git exits with a non-zero status and + prints an error message, that usually doesn’t mean that it is an + error as far as Magit is concerned, which is another reason we + usually hide these error messages. Whether some error message is + relevant in the context of some unexpected behavior has to be + judged on a case by case basis. + +Key: M-x magit-toggle-verbose-refresh + This command toggles whether Magit refreshes buffers verbosely. + Enabling this helps figuring out which sections are bottlenecks. + The additional output can be found in the ‘*Messages*’ buffer. + +Key: M-x magit-toggle-subprocess-record + This command toggles whether subprocess invocations are recorded. + + When enabled, all subprocesses started by ‘magit-process-file’ are + logged into the buffer specified by + ‘magit-process-record-buffer-name’ using the format + ‘magit-process-record-entry-format’. This is for debugging + purposes. + + This is in addition to and distinct from the default logging done + by default, and additional logging enabled with + ‘magit-toggle-git-debug’. + +Key: M-x magit-debug-git-executable + This command displays a buffer containing information about the + available and used ‘git’ executable(s), and can be useful when + investigating ‘exec-path’ issues. + + Also see *note Git Executable::. + +Key: M-x magit-profile-refresh-buffer + This command profiles refreshing the current Magit buffer and then + displays the results. + +Key: M-x magit-toggle-profiling + This command starts profiling Magit and Forge, or if profiling is + already in progress, it instead stops that and displays the + results. + +Key: M-x with-editor-debug + This command displays a buffer containing information about the + available and used ‘emacsclient’ executable(s), and can be useful + when investigating why Magit (or rather ‘with-editor’) cannot find + an appropriate ‘emacsclient’ executable. + + Also see *note (with-editor)Debugging::. + +Please also see *note FAQ::. + + +File: doc5khxAZ.info, Node: Keystroke Index, Next: Function and Command Index, Prev: Debugging Tools, Up: Top + +Appendix C Keystroke Index +************************** + + +File: doc5khxAZ.info, Node: Function and Command Index, Next: Variable Index, Prev: Keystroke Index, Up: Top + +Appendix D Function and Command Index +************************************* + + +File: doc5khxAZ.info, Node: Variable Index, Prev: Function and Command Index, Up: Top + +Appendix E Variable Index +************************* + + + +Tag Table: +Node: Top778 +Node: Introduction6621 +Node: Installation11341 +Node: Installing from Melpa11675 +Node: Installing from the Git Repository12754 +Node: Post-Installation Tasks15810 +Node: Getting Started17097 +Node: Interface Concepts22912 +Node: Modes and Buffers23295 +Node: Switching Buffers25009 +Node: Naming Buffers29704 +Node: Quitting Windows32767 +Node: Automatic Refreshing of Magit Buffers34687 +Node: Automatic Saving of File-Visiting Buffers37546 +Node: Automatic Reverting of File-Visiting Buffers38730 +Node: Risk of Reverting Automatically43679 +Node: Sections46065 +Node: Section Movement46995 +Node: Section Visibility52378 +Node: Section Hooks58941 +Node: Section Types and Values61337 +Node: Section Options62745 +Node: Transient Commands63216 +Node: Transient Arguments and Buffer Variables64683 +Node: Completion Confirmation and the Selection71696 +Node: Action Confirmation72146 +Node: Completion and Confirmation80651 +Node: The Selection83837 +Node: The hunk-internal region86735 +Node: Support for Completion Frameworks87828 +Node: Additional Completion Options92671 +Node: Mouse Support93269 +Node: Running Git93849 +Node: Viewing Git Output94098 +Node: Git Process Status96085 +Node: Running Git Manually97308 +Node: Git Executable99928 +Node: Global Git Arguments102930 +Node: Inspecting103737 +Node: Status Buffer104898 +Node: Status Sections109948 +Node: Status File List Sections112717 +Node: Status Log Sections115396 +Node: Status Header Sections116863 +Node: Status Module Sections119446 +Node: Status Options121915 +Node: Repository List123278 +Node: Logging127963 +Node: Refreshing Logs130751 +Node: Log Buffer132141 +Node: Log Margin136871 +Node: Select from Log139992 +Node: Reflog142188 +Node: Cherries143806 +Node: Diffing145639 +Node: Refreshing Diffs149633 +Node: Commands Available in Diffs153228 +Node: Diff Options155702 +Node: Revision Buffer161759 +Node: Ediffing165067 +Node: References Buffer171021 +Node: References Sections181539 +Node: Bisecting182384 +Node: Visiting Files and Blobs184641 +Node: General-Purpose Visit Commands185173 +Node: Visiting Files and Blobs from a Diff186118 +Node: Blaming189456 +Node: Manipulating196264 +Node: Creating Repository196610 +Node: Cloning Repository197144 +Node: Staging and Unstaging203505 +Node: Staging from File-Visiting Buffers207448 +Node: Applying208556 +Node: Committing210612 +Node: Initiating a Commit211305 +Node: Creating a new commit211904 +Node: Editing the last commit212119 +Node: Editing any reachable commit214226 +Node: Editing any reachable commit and rebasing immediately218785 +Node: Options used by commit commands220608 +Ref: Used by all or most commit commands220832 +Ref: Used by all squash and fixup commands223047 +Ref: Used by specific commit commands223591 +Node: Editing Commit Messages223907 +Node: Using the Revision Stack226642 +Node: Commit Pseudo Headers229680 +Node: Commit Mode and Hooks230919 +Node: Commit Message Conventions233741 +Node: Branching235716 +Node: The Two Remotes235946 +Node: Branch Commands238603 +Node: Branch Git Variables251357 +Node: Auxiliary Branch Commands256678 +Node: Merging257790 +Node: Resolving Conflicts261885 +Node: Rebasing267263 +Node: Editing Rebase Sequences272210 +Node: Information About In-Progress Rebase277367 +Ref: Information About In-Progress Rebase-Footnote-1286484 +Node: Cherry Picking287080 +Node: Reverting291350 +Node: Resetting292731 +Node: Stashing294507 +Node: Transferring300631 +Node: Remotes300857 +Node: Remote Commands301013 +Node: Remote Git Variables304994 +Node: Fetching306249 +Node: Pulling308677 +Node: Pushing309680 +Node: Plain Patches313905 +Node: Maildir Patches315352 +Node: Miscellaneous316789 +Node: Tagging317139 +Node: Notes319003 +Node: Submodules321287 +Node: Listing Submodules321511 +Node: Submodule Transient323655 +Node: Subtree326041 +Node: Worktree327915 +Node: Sparse checkouts328955 +Node: Bundle331695 +Node: Common Commands332072 +Node: Wip Modes334677 +Node: Wip Graph339544 +Node: Legacy Wip Modes341857 +Node: Commands for Buffers Visiting Files344716 +Node: Minor Mode for Buffers Visiting Blobs352598 +Node: Customizing353379 +Node: Per-Repository Configuration354979 +Node: Essential Settings357235 +Node: Safety357585 +Node: Performance359350 +Ref: Log Performance362317 +Ref: Diff Performance363622 +Ref: Refs Buffer Performance364963 +Ref: Committing Performance365538 +Node: Microsoft Windows Performance366520 +Node: MacOS Performance367715 +Ref: MacOS Performance-Footnote-1368742 +Node: Global Bindings368824 +Node: Plumbing371052 +Node: Calling Git371885 +Node: Getting a Value from Git373414 +Node: Calling Git for Effect377084 +Node: Section Plumbing382934 +Node: Creating Sections383166 +Node: Section Selection387050 +Node: Matching Sections388838 +Node: Refreshing Buffers394730 +Node: Conventions397842 +Node: Theming Faces398038 +Node: FAQ406147 +Node: FAQ - How to ...?406589 +Node: How to pronounce Magit?406950 +Node: How to show git's output?407758 +Node: How to install the gitman info manual?408544 +Node: How to show diffs for gpg-encrypted files?409535 +Node: How does branching and pushing work?410135 +Node: Should I disable VC?410472 +Node: FAQ - Issues and Errors411079 +Node: Magit is slow412028 +Node: I changed several thousand files at once and now Magit is unusable412325 +Node: I am having problems committing413055 +Node: I am using MS Windows and cannot push with Magit413546 +Node: I am using macOS and SOMETHING works in shell but not in Magit414168 +Node: Expanding a file to show the diff causes it to disappear415006 +Node: Point is wrong in the COMMIT_EDITMSG buffer415598 +Node: The mode-line information isn't always up-to-date416651 +Node: A branch and tag sharing the same name breaks SOMETHING417718 +Node: My Git hooks work on the command-line but not inside Magit418609 +Node: git-commit-mode isn't used when committing from the command-line419459 +Node: Point ends up inside invisible text when jumping to a file-visiting buffer421734 +Node: I am no longer able to save popup defaults422587 +Node: Debugging Tools423572 +Node: Keystroke Index427506 +Node: Function and Command Index427678 +Node: Variable Index427871 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: blob - /dev/null blob + d6ecd907f35201b204e6d09c4c17f082677ed4e6 (mode 644) --- /dev/null +++ elpa/magit-4.3.8.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2025-07-05T11:10:20+0200 using EDDSA \ No newline at end of file blob - /dev/null blob + ea760dc2f3ce0f086e8bfc5f087b83d549294683 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/.dir-locals.el @@ -0,0 +1,15 @@ +((nil + (indent-tabs-mode . nil)) + (makefile-mode + (indent-tabs-mode . t) + (outline-regexp . "#\\(#+\\)") + (mode . outline-minor)) + (emacs-lisp-mode + (checkdoc-allow-quoting-nil-and-t . t)) + (git-commit-mode + (git-commit-major-mode . git-commit-elisp-text-mode)) + (".github/PULL_REQUEST_TEMPLATE" + (nil (truncate-lines . nil))) + ("CHANGELOG" + (nil (fill-column . 70) + (mode . display-fill-column-indicator)))) blob - /dev/null blob + 6e4468131a67d761f04d374b1af0de742dd0c7e3 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/dir @@ -0,0 +1,19 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* Magit-Section: (magit-section). + Use Magit sections in your own packages. blob - /dev/null blob + 3579bf2ead0980f7552185f6e58c6bf6ddcbcbed (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-autorevert.el @@ -0,0 +1,271 @@ +;;; magit-autorevert.el --- Revert buffers when files in repository change -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; This library implements support for automatically reverting buffers +;; when visited files in the repository change. + +;; See (info "(magit)Automatic Reverting of File-Visiting Buffers"). + +;;; Code: + +(require 'magit-process) + +(require 'autorevert) + +;;; Options + +(defgroup magit-auto-revert nil + "Revert buffers when files in repository change." + :link '(custom-group-link auto-revert) + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'auto-revert + :group 'magit-essentials + :group 'magit-modes) + +(defcustom auto-revert-buffer-list-filter nil + "Filter that determines which buffers `auto-revert-buffers' reverts. + +This option is provided by Magit, which also advises +`auto-revert-buffers' to respect it. Magit users who do not turn +on the local mode `auto-revert-mode' themselves, are best served +by setting the value to `magit-auto-revert-repository-buffer-p'. + +However the default is nil, so as not to disturb users who do use +the local mode directly. If you experience delays when running +Magit commands, then you should consider using one of the +predicates provided by Magit - especially if you also use Tramp. + +Users who do turn on `auto-revert-mode' in buffers in which Magit +doesn't do that for them, should likely not use any filter. +Users who turn on `global-auto-revert-mode', do not have to worry +about this option, because it is disregarded if the global mode +is enabled." + :package-version '(magit . "2.4.2") + :group 'auto-revert + :group 'magit-auto-revert + :group 'magit-related + :type `(radio (const :tag "No filter" nil) + (function-item ,#'magit-auto-revert-buffer-p) + (function-item ,#'magit-auto-revert-repository-buffer-p) + function)) + +(defcustom magit-auto-revert-tracked-only t + "Whether `magit-auto-revert-mode' only reverts tracked files." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean + :set (lambda (var val) + (set var val) + (when (and (bound-and-true-p magit-auto-revert-mode) + (featurep 'magit-autorevert)) + (magit-auto-revert-mode -1) + (magit-auto-revert-mode)))) + +(defcustom magit-auto-revert-immediately t + "Whether Magit reverts buffers immediately. + +If this is non-nil and either `global-auto-revert-mode' or +`magit-auto-revert-mode' is enabled, then Magit immediately +reverts buffers by explicitly calling `auto-revert-buffers' +after running Git for side-effects. + +If `auto-revert-use-notify' is non-nil (and file notifications +are actually supported), then `magit-auto-revert-immediately' +does not have to be non-nil, because the reverts happen +immediately anyway. + +If `magit-auto-revert-immediately' and `auto-revert-use-notify' +are both nil, then reverts happen after `auto-revert-interval' +seconds of user inactivity. That is not desirable." + :package-version '(magit . "2.4.0") + :group 'magit-auto-revert + :type 'boolean) + +;;; Mode + +(defun magit-turn-on-auto-revert-mode-if-desired (&optional file) + (cond (file + (when-let ((buffer (find-buffer-visiting file))) + (with-current-buffer buffer + (magit-turn-on-auto-revert-mode-if-desired)))) + ((and (not auto-revert-mode) ; see #3014 + (not global-auto-revert-mode) ; see #3460 + buffer-file-name + (or auto-revert-remote-files ; see #5422 + (not (file-remote-p buffer-file-name))) + (file-readable-p buffer-file-name) + (compat-call executable-find (magit-git-executable) t) + (magit-toplevel) + (or (not magit-auto-revert-tracked-only) + (magit-file-tracked-p buffer-file-name))) + (auto-revert-mode 1)))) + +;;;###autoload +(define-globalized-minor-mode magit-auto-revert-mode auto-revert-mode + magit-turn-on-auto-revert-mode-if-desired + :package-version '(magit . "2.4.0") + :link '(info-link "(magit)Automatic Reverting of File-Visiting Buffers") + :group 'magit-auto-revert + :group 'magit-essentials + ;; - When `global-auto-revert-mode' is enabled, then this mode is + ;; redundant. + ;; - In all other cases enable the mode because if buffers are not + ;; automatically reverted that would make many very common tasks + ;; much more cumbersome. + :init-value (not (or global-auto-revert-mode + noninteractive))) +;; - Unfortunately `:init-value t' only sets the value of the mode +;; variable but does not cause the mode function to be called. +;; - I don't think it works like this on purpose, but since one usually +;; should not enable global modes by default, it is understandable. +;; - If the user has set the variable `magit-auto-revert-mode' to nil +;; after loading magit (instead of doing so before loading magit or +;; by using the function), then we should still respect that setting. +;; - If the user enables `global-auto-revert-mode' after loading magit +;; and after `after-init-hook' has run, then `magit-auto-revert-mode' +;; remains enabled; and there is nothing we can do about it. +;; - However if the init file causes `magit-autorevert' to be loaded +;; and only later it enables `global-auto-revert-mode', then we can +;; and should leave `magit-auto-revert-mode' disabled. +(defun magit-auto-revert-mode--init-kludge () + "This is an internal kludge to be used on `after-init-hook'. +Do not use this function elsewhere, and don't remove it from +the `after-init-hook'. For more information see the comments +and code surrounding the definition of this function." + (if (or (not magit-auto-revert-mode) + (and global-auto-revert-mode (not after-init-time))) + (magit-auto-revert-mode -1) + (let ((start (current-time))) + (magit-message "Turning on magit-auto-revert-mode...") + (magit-auto-revert-mode 1) + (magit-message + "Turning on magit-auto-revert-mode...done%s" + (let ((elapsed (float-time (time-since start)))) + (if (> elapsed 0.2) + (format " (%.3fs, %s buffers checked)" elapsed + (length (buffer-list))) + "")))))) +(if after-init-time + ;; Since `after-init-hook' has already been + ;; run, turn the mode on or off right now. + (magit-auto-revert-mode--init-kludge) + ;; By the time the init file has been fully loaded the + ;; values of the relevant variables might have changed. + (add-hook 'after-init-hook #'magit-auto-revert-mode--init-kludge t)) + +(put 'magit-auto-revert-mode 'function-documentation + "Toggle Magit Auto Revert mode. +If called interactively, enable Magit Auto Revert mode if ARG is +positive, and disable it if ARG is zero or negative. If called +from Lisp, also enable the mode if ARG is omitted or nil, and +toggle it if ARG is `toggle'; disable the mode otherwise. + +Magit Auto Revert mode is a global minor mode that reverts +buffers associated with a file that is located inside a Git +repository when the file changes on disk. Use `auto-revert-mode' +to revert a particular buffer. Or use `global-auto-revert-mode' +to revert all file-visiting buffers, not just those that visit +a file located inside a Git repository. + +This global mode works by turning on the buffer-local mode +`auto-revert-mode' at the time a buffer is first created. The +local mode is turned on if the visited file is being tracked in +a Git repository at the time when the buffer is created. + +If `magit-auto-revert-tracked-only' is non-nil (the default), +then only tracked files are reverted. But if you stage a +previously untracked file using `magit-stage', then this mode +notices that. + +Unlike `global-auto-revert-mode', this mode never reverts any +buffers that are not visiting files. + +The behavior of this mode can be customized using the options +in the `autorevert' and `magit-autorevert' groups. + +This function calls the hook `magit-auto-revert-mode-hook'. + +Like nearly every mode, this mode should be enabled or disabled +by calling the respective mode function, the reason being that +changing the state of a mode involves more than merely toggling +a single switch, so setting the mode variable is not enough. +Also, you should not use `after-init-hook' to disable this mode.") + +(defun magit-auto-revert-buffers () + (when (and magit-auto-revert-immediately + (or global-auto-revert-mode + (and magit-auto-revert-mode auto-revert-buffer-list))) + (let ((auto-revert-buffer-list-filter + (or auto-revert-buffer-list-filter + #'magit-auto-revert-repository-buffer-p))) + (auto-revert-buffers)))) + +(defvar magit-auto-revert-toplevel nil) + +(defvar magit-auto-revert-counter 1 + "Incremented each time `auto-revert-buffers' is called.") + +(defun magit-auto-revert-buffer-p (buffer) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return t for any BUFFER." + (magit-auto-revert-repository-buffer-p buffer t)) + +(defun magit-auto-revert-repository-buffer-p (buffer &optional fallback) + "Return non-nil if BUFFER visits a file inside the current repository. +The current repository is the one containing `default-directory'. +If there is no current repository, then return FALLBACK (which +defaults to nil) for any BUFFER." + ;; Call `magit-toplevel' just once per cycle. + (unless (and magit-auto-revert-toplevel + (= (cdr magit-auto-revert-toplevel) + magit-auto-revert-counter)) + (setq magit-auto-revert-toplevel + (cons (or (magit-toplevel) 'no-repo) + magit-auto-revert-counter))) + (let ((top (car magit-auto-revert-toplevel))) + (if (eq top 'no-repo) + fallback + (let ((dir (buffer-local-value 'default-directory buffer))) + (and (equal (file-remote-p dir) + (file-remote-p top)) + ;; ^ `tramp-handle-file-in-directory-p' lacks this optimization. + (file-in-directory-p dir top)))))) + +(define-advice auto-revert-buffers (:around (fn) buffer-list-filter) + (cl-incf magit-auto-revert-counter) + (if (or global-auto-revert-mode + (not auto-revert-buffer-list) + (not auto-revert-buffer-list-filter)) + (funcall fn) + (let ((auto-revert-buffer-list + (seq-filter auto-revert-buffer-list-filter + auto-revert-buffer-list))) + (funcall fn)) + (unless auto-revert-timer + (auto-revert-set-timer)))) + +;;; _ +(provide 'magit-autorevert) +;;; magit-autorevert.el ends here blob - /dev/null blob + 5e361ac9f3dda20ef566edd60608acca3f6a0f38 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-dired.el @@ -0,0 +1,109 @@ +;;; magit-dired.el --- Dired support for Magit -*- lexical-binding:t -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;;; Commentary: + +;; Dired support for Magit. + +;;; Code: + +(require 'magit) + +;; For `magit-do-async-shell-command'. +(declare-function dired-read-shell-command "dired-aux" (prompt arg files)) + +;;; Open Dired from Magit + +;;;###autoload +(defun magit-dired-jump (&optional other-window) + "Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'." + (interactive "P") + (dired-jump other-window + (and-let* ((file (magit-file-at-point))) + (expand-file-name (if (file-directory-p file) + (file-name-as-directory file) + file))))) + +;;; Commands for Dired Buffers + +;;;###autoload +(defun magit-dired-stage () + "In Dired, staged all marked files or the file at point." + (interactive) + (magit-stage-files (dired-get-marked-files))) + +;;;###autoload +(defun magit-dired-unstage () + "In Dired, unstaged all marked files or the file at point." + (interactive) + (magit-unstage-files (dired-get-marked-files))) + +;;;###autoload +(defun magit-dired-log (&optional follow) + "In Dired, show log for all marked files or the directory if none are marked." + (interactive "P") + (if-let ((topdir (magit-toplevel default-directory))) + (let ((args (car (magit-log-arguments))) + (files (or (dired-get-marked-files nil 'marked) + (list default-directory)))) + (when (and follow + (not (member "--follow" args)) + (not (cdr files))) + (push "--follow" args)) + (magit-log-setup-buffer + (list (or (magit-get-current-branch) "HEAD")) + args + (let ((default-directory topdir)) + (mapcar #'file-relative-name files)) + magit-log-buffer-file-locked)) + (magit--not-inside-repository-error))) + +;;;###autoload +(defun magit-dired-am-apply-patches (repo &optional arg) + "In Dired, apply the marked (or next ARG) files as patches. +If inside a repository, then apply in that. Otherwise prompt +for a repository." + (interactive (list (or (magit-toplevel) + (magit-read-repository t)) + current-prefix-arg)) + (let ((files (dired-get-marked-files nil arg nil nil t))) + (magit-status-setup-buffer repo) + (magit-am-apply-patches files))) + +;;; Miscellaneous Commands + +;;;###autoload +(defun magit-do-async-shell-command (file) + "Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point." + (interactive (list (or (magit-file-at-point) + (magit-read-file "Act on file")))) + (require 'dired-aux) + (dired-do-async-shell-command + (dired-read-shell-command "& on %s: " current-prefix-arg (list file)) + nil (list file))) + +;;; _ +(provide 'magit-dired) +;;; magit-dired.el ends here blob - /dev/null blob + d90657e56fa07a1191c1b530e1214e5341f2cb9d (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-section-autoloads.el @@ -0,0 +1,125 @@ +;;; magit-section-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from magit-autorevert.el + +(put 'magit-auto-revert-mode 'globalized-minor-mode t) +(defvar magit-auto-revert-mode (not (or global-auto-revert-mode noninteractive)) "\ +Non-nil if Magit-Auto-Revert mode is enabled. +See the `magit-auto-revert-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `magit-auto-revert-mode'.") +(custom-autoload 'magit-auto-revert-mode "magit-autorevert" nil) +(autoload 'magit-auto-revert-mode "magit-autorevert" "\ +Toggle Auto-Revert mode in all buffers. +With prefix ARG, enable Magit-Auto-Revert mode if ARG is positive; +otherwise, disable it. + +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. +Disable the mode if ARG is a negative number. + +Auto-Revert mode is enabled in all buffers where +`magit-turn-on-auto-revert-mode-if-desired' would do it. + +See `auto-revert-mode' for more information on Auto-Revert mode. + +(fn &optional ARG)" t) +(register-definition-prefixes "magit-autorevert" '("auto-revert-buffer" "magit-")) + + +;;; Generated autoloads from magit-dired.el + +(autoload 'magit-dired-jump "magit-dired" "\ +Visit file at point using Dired. +With a prefix argument, visit in another window. If there +is no file at point, then instead visit `default-directory'. + +(fn &optional OTHER-WINDOW)" t) +(autoload 'magit-dired-stage "magit-dired" "\ +In Dired, staged all marked files or the file at point." t) +(autoload 'magit-dired-unstage "magit-dired" "\ +In Dired, unstaged all marked files or the file at point." t) +(autoload 'magit-dired-log "magit-dired" "\ +In Dired, show log for all marked files or the directory if none are marked. + +(fn &optional FOLLOW)" t) +(autoload 'magit-dired-am-apply-patches "magit-dired" "\ +In Dired, apply the marked (or next ARG) files as patches. +If inside a repository, then apply in that. Otherwise prompt +for a repository. + +(fn REPO &optional ARG)" t) +(autoload 'magit-do-async-shell-command "magit-dired" "\ +Open FILE with `dired-do-async-shell-command'. +Interactively, open the file at point. + +(fn FILE)" t) + + +;;; Generated autoloads from magit-section.el + +(autoload 'magit-add-section-hook "magit-section" "\ +Add to the value of section hook HOOK the function FUNCTION. + +Add FUNCTION at the beginning of the hook list unless optional +APPEND is non-nil, in which case FUNCTION is added at the end. +If FUNCTION already is a member, then move it to the new location. + +If optional AT is non-nil and a member of the hook list, then +add FUNCTION next to that instead. Add before or after AT, or +replace AT with FUNCTION depending on APPEND. If APPEND is the +symbol `replace', then replace AT with FUNCTION. For any other +non-nil value place FUNCTION right after AT. If nil, then place +FUNCTION right before AT. If FUNCTION already is a member of the +list but AT is not, then leave FUNCTION where ever it already is. + +If optional LOCAL is non-nil, then modify the hook's buffer-local +value rather than its global value. This makes the hook local by +copying the default value. That copy is then modified. + +HOOK should be a symbol. If HOOK is void, it is first set to nil. +HOOK's value must not be a single hook function. FUNCTION should +be a function that takes no arguments and inserts one or multiple +sections at point, moving point forward. FUNCTION may choose not +to insert its section(s), when doing so would not make sense. It +should not be abused for other side-effects. To remove FUNCTION +again use `remove-hook'. + +(fn HOOK FUNCTION &optional AT APPEND LOCAL)") +(autoload 'magit--handle-bookmark "magit-section" "\ +Open a bookmark created by `magit--make-bookmark'. + +Call the generic function `magit-bookmark-get-buffer-create' to get +the appropriate buffer without displaying it. + +Then call the `magit-*-setup-buffer' function of the the major-mode +with the variables' values as arguments, which were recorded by +`magit--make-bookmark'. + +(fn BOOKMARK)") +(register-definition-prefixes "magit-section" '("context-menu-region" "isearch-clean-overlays" "magit-")) + +;;; End of scraped data + +(provide 'magit-section-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; magit-section-autoloads.el ends here blob - /dev/null blob + 3371355b1a36d350db52ec39e724d656899476ab (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-section-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from magit-section.el -*- no-byte-compile: t -*- +(define-package "magit-section" "4.3.8" "Sections for read-only buffers" '((emacs "27.1") (compat "30.1") (llama "1.0.0") (seq "2.24")) :commit "5b820a1d1e94649e0f218362286d520d9f29ac2c" :authors '(("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev")) :maintainer '("Jonas Bernoulli" . "emacs.magit@jonas.bernoulli.dev") :keywords '("tools") :url "https://github.com/magit/magit") blob - /dev/null blob + 003cacd114dd2b2f77dd6d3bd62e29e64f3d6a99 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-section.el @@ -0,0 +1,2646 @@ +;;; magit-section.el --- Sections for read-only buffers -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2008-2025 The Magit Project Contributors + +;; Author: Jonas Bernoulli +;; Maintainer: Jonas Bernoulli + +;; Homepage: https://github.com/magit/magit +;; Keywords: tools + +;; Package-Version: 4.3.8 +;; Package-Requires: ( +;; (emacs "27.1") +;; (compat "30.1") +;; (llama "1.0.0") +;; (seq "2.24")) + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;; Magit 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 3 of the License, +;; or (at your option) any later version. +;; +;; Magit 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 Magit. If not, see . + +;; You should have received a copy of the AUTHORS.md file, which +;; lists all contributors. If not, see https://magit.vc/authors. + +;;; Commentary: + +;; This package implements the main user interface of Magit — the +;; collapsible sections that make up its buffers. This package used +;; to be distributed as part of Magit but now it can also be used by +;; other packages that have nothing to do with Magit or Git. + +;;; Code: + +(require 'cl-lib) +(require 'compat) +(require 'eieio) +(require 'llama) +(require 'subr-x) + +;; For older Emacs releases we depend on an updated `seq' release from GNU +;; ELPA, for `seq-keep'. Unfortunately something else may require `seq' +;; before `package' had a chance to put this version on the `load-path'. +(when (and (featurep 'seq) + (not (fboundp 'seq-keep))) + (unload-feature 'seq 'force)) +(require 'seq) +;; Furthermore, by default `package' just silently refuses to upgrade. +(defconst magit--core-upgrade-instructions "\ +Magit requires `%s' >= %s, +but due to bad defaults, Emacs' package manager, refuses to +upgrade this and other built-in packages to higher releases +from GNU Elpa. + +To fix this, you have to add this to your init file: + + (setq package-install-upgrade-built-in t) + +Then evaluate that expression by placing the cursor after it +and typing \\[eval-last-sexp]. + +Once you have done that, you have to explicitly upgrade `%s': + + \\[package-install] %s \\`RET' + +Then you also must make sure the updated version is loaded, +by evaluating this form: + + (progn (unload-feature \\='%s t) (require \\='%s)) + +If this does not work, then try uninstalling Magit and all of its +dependencies. After that exit and restart Emacs, and only then +reinstalling Magit. + +If you don't use the `package' package manager but still get +this warning, then your chosen package manager likely has a +similar defect.") +(unless (fboundp 'seq-keep) + (display-warning 'magit (substitute-command-keys + (format magit--core-upgrade-instructions + 'seq "2.24" 'seq 'seq 'seq 'seq)) + :emergency)) + +(require 'cursor-sensor) +(require 'format-spec) + +(eval-when-compile (require 'benchmark)) + +;; For `magit-section-get-relative-position' +(declare-function magit-hunk-section-p "magit-diff" (section) t) + +(define-obsolete-variable-alias 'magit-keep-region-overlay + 'magit-section-keep-region-overlay "Magit-Section 4.0.0") + +;;; Hooks + +(defvar magit-section-movement-hook nil + "Hook run by `magit-section-goto'. +That function in turn is used by all section movement commands. +See also info node `(magit)Section Movement'.") + +(defvar magit-section-set-visibility-hook + (list #'magit-section-cached-visibility) + "Hook used to set the initial visibility of a section. +Stop at the first function that returns non-nil. The returned +value should be `show', `hide' or nil. If no function returns +non-nil, determine the visibility as usual, i.e., use the +hardcoded section specific default (see `magit-insert-section').") + +;;; Options + +(defgroup magit-section nil + "Expandable sections." + :link '(info-link "(magit)Sections") + :group 'extensions) + +(defcustom magit-section-highlight-current t + "Whether to highlight the current section." + :package-version '(magit-section . "4.3.6") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-highlight-selection t + "Whether to highlight the selected sections. +If you disable this, you probably also want to disable +`magit-section-highlight-current' to get the region to +always look as it would be in non-magit buffers." + :package-version '(magit-section . "4.3.6") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-show-child-count t + "Whether to append the number of children to section headings. +This only applies to sections for which doing so makes sense." + :package-version '(magit-section . "2.1.0") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-cache-visibility t + "Whether to cache visibility of sections. + +Sections always retain their visibility state when they are being +recreated during a refresh. But if a section disappears and then +later reappears again, then this option controls whether this is +the case. + +If t, then cache the visibility of all sections. If a list of +section types, then only do so for matching sections. If nil, +then don't do so for any sections." + :package-version '(magit-section . "2.12.0") + :group 'magit-section + :type '(choice (const :tag "Don't cache visibility" nil) + (const :tag "Cache visibility of all sections" t) + (repeat :tag "Cache visibility for section types" symbol))) + +(defcustom magit-section-initial-visibility-alist + '((stashes . hide)) + "Alist controlling the initial visibility of sections. + +Each element maps a section type or lineage to the initial +visibility state for such sections. The state has to be one of +`show' or `hide', or a function that returns one of these symbols. +A function is called with the section as the only argument. + +Use the command `magit-describe-section' to determine a section's +lineage or type. The vector in the output is the section lineage +and the type is the first element of that vector. Wildcards can +be used, see `magit-section-match'. + +Currently this option is only used to override hardcoded defaults, +but in the future it will also be used set the defaults. + +An entry whose key is `magit-status-initial-section' specifies +the visibility of the section `magit-status-goto-initial-section' +jumps to. This does not only override defaults, but also other +entries of this alist." + :package-version '(magit-section . "2.12.0") + :group 'magit-section + :type '(alist :key-type (sexp :tag "Section type/lineage") + :value-type (choice (const hide) + (const show) + function))) + +(defcustom magit-section-visibility-indicator + (if (window-system) + '(magit-fringe-bitmap> . magit-fringe-bitmapv) + (cons (if (char-displayable-p ?…) "…" "...") + t)) + "Whether and how to indicate that a section can be expanded/collapsed. + +If nil, then don't show any indicators. +Otherwise the value has to have one of these two forms: + +\(EXPANDABLE-BITMAP . COLLAPSIBLE-BITMAP) + + Both values have to be variables whose values are fringe + bitmaps. In this case every section that can be expanded or + collapsed gets an indicator in the left fringe. + + To provide extra padding around the indicator, set + `left-fringe-width' in `magit-mode-hook'. + +\(STRING . BOOLEAN) + + In this case STRING (usually an ellipsis) is shown at the end + of the heading of every collapsed section. Expanded sections + get no indicator. The cdr controls whether the appearance of + these ellipsis take section highlighting into account. Doing + so might potentially have an impact on performance, while not + doing so is kinda ugly." + :package-version '(magit-section . "3.0.0") + :group 'magit-section + :type '(choice (const :tag "No indicators" nil) + (cons :tag "Use +- fringe indicators" + (const magit-fringe-bitmap+) + (const magit-fringe-bitmap-)) + (cons :tag "Use >v fringe indicators" + (const magit-fringe-bitmap>) + (const magit-fringe-bitmapv)) + (cons :tag "Use bold >v fringe indicators)" + (const magit-fringe-bitmap-bold>) + (const magit-fringe-bitmap-boldv)) + (cons :tag "Use custom fringe indicators" + (variable :tag "Expandable bitmap variable") + (variable :tag "Collapsible bitmap variable")) + (cons :tag "Use ellipses at end of headings" + (string :tag "Ellipsis" "…") + (choice :tag "Use face kludge" + (const :tag "Yes (potentially slow)" t) + (const :tag "No (kinda ugly)" nil))))) + +(defcustom magit-section-keep-region-overlay nil + "Whether to keep the region overlay when there is a valid selection. + +We strongly suggest that you keep the default value, nil. + +By default Magit removes the regular region overlay if, and only +if, that region constitutes a valid selection as understood by +Magit commands. Otherwise it does not remove that overlay, and +the region looks like it would in other buffers. + +There are two types of such valid selections: hunk-internal +regions and regions that select two or more sibling sections. +In such cases Magit removes the region overlay and instead +highlights a slightly larger range. All text (for hunk-internal +regions) or the headings of all sections (for sibling selections) +that are inside that range (not just inside the region) are acted +on by commands such as the staging command. This buffer range +begins at the beginning of the line on which the region begins +and ends at the end of the line on which the region ends. + +Because Magit acts on this larger range and not the region, it is +actually quite important to visualize that larger range. If we +don't do that, then one might think that these commands act on +the region instead. If you want to *also* visualize the region, +then set this option to t. But please note that when the region +does *not* constitute a valid selection, then the region is +*always* visualized as usual, and that it is usually under such +circumstances that you want to use a non-magit command to act on +the region. + +Depending on the used theme, the `magit-*-highlight-selection' +faces might conflict with the `region' face. If that happens and +it bothers you, then you have to customize these faces to address +the conflicts." + :package-version '(magit-section . "2.3.0") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-disable-line-numbers t + "In Magit buffers, whether to disable modes that display line numbers. + +Some users who turn on `global-display-line-numbers-mode' (or +`global-nlinum-mode' or `global-linum-mode') expect line numbers +to be displayed everywhere except in Magit buffers. Other users +do not expect Magit buffers to be treated differently. At least +in theory users in the first group should not use the global mode, +but that ship has sailed, thus this option." + :package-version '(magit-section . "3.0.0") + :group 'magit-section + :type 'boolean) + +(defcustom magit-section-show-context-menu-for-emacs<28 nil + "Whether `mouse-3' shows a context menu for Emacs < 28. + +This has to be set before loading `magit-section' or it has +no effect. This also has no effect for Emacs >= 28, where +`context-menu-mode' should be enabled instead." + :package-version '(magit-section . "4.0.0") + :group 'magit-section + :type 'boolean) + +;;; Variables + +(defvar-local magit-section-preserve-visibility t) + +(defvar-local magit-section-pre-command-region-p nil) +(defvar-local magit-section-pre-command-section nil) + +(defvar-local magit-section-highlight-force-update nil) +(defvar-local magit-section-highlight-overlays nil) +(defvar-local magit-section-selection-overlays nil) +(defvar-local magit-section-highlighted-sections nil + "List of highlighted sections that may have to be repainted on focus change.") +(defvar-local magit-section-focused-sections nil) + +(defvar-local magit-section-inhibit-markers nil) +(defvar-local magit-section-insert-in-reverse nil) + +(defvar-local magit--refreshing-buffer-p nil + "Whether the current buffer is presently being refreshed.") + +;;; Faces + +(defgroup magit-section-faces nil + "Faces used by Magit-Section." + :group 'magit-section + :group 'faces) + +(defface magit-section-highlight + '((((class color) (background light)) + :extend t + :background "grey95") + (((class color) (background dark)) + :extend t + :background "grey20")) + "Face for highlighting the current section." + :group 'magit-section-faces) + +(defface magit-section-heading + '((((class color) (background light)) + :extend t + :foreground "DarkGoldenrod4" + :weight bold) + (((class color) (background dark)) + :extend t + :foreground "LightGoldenrod2" + :weight bold)) + "Face for section headings." + :group 'magit-section-faces) + +(defface magit-section-secondary-heading + '((t :extend t :weight bold)) + "Face for section headings of some secondary headings." + :group 'magit-section-faces) + +(defface magit-section-heading-selection + '((((class color) (background light)) + :extend t + :foreground "salmon4") + (((class color) (background dark)) + :extend t + :foreground "LightSalmon3")) + "Face for selected section headings." + :group 'magit-section-faces) + +(defface magit-section-child-count '((t nil)) + "Face used for child counts at the end of some section headings." + :group 'magit-section-faces) + +;;; Classes + +(defvar magit--current-section-hook nil + "Internal variable used for `magit-describe-section'.") + +(defvar magit--section-type-alist nil) + +(defclass magit-section () + ((type :initform nil :initarg :type) + (keymap :initform nil) + (value :initform nil) + (start :initform nil) + (content :initform nil) + (end :initform nil) + (hidden) + (painted) + (washer :initform nil :initarg :washer) + (inserter :initform (symbol-value 'magit--current-section-hook)) + (selective-highlight :initform nil :initarg :selective-highlight) + (heading-highlight-face :initform nil :initarg :heading-highlight-face) + (heading-selection-face :initform nil :initarg :heading-selection-face) + (parent :initform nil) + (children :initform nil))) + +;;; Mode + +(defvar symbol-overlay-inhibit-map) + +(defvar-keymap magit-section-heading-map + :doc "Keymap used in the heading line of all expandable sections. +This keymap is used in addition to the section-specific keymap, if any." + "" #'ignore + "" #'magit-mouse-toggle-section + "" #'magit-mouse-toggle-section) + +(defvar magit-section-mode-map + (let ((map (make-keymap))) + (suppress-keymap map t) + (when (and magit-section-show-context-menu-for-emacs<28 + (< emacs-major-version 28)) + (keymap-set map "" nil) + (keymap-set + map "" + `( menu-item "" ,(make-sparse-keymap) + :filter ,(lambda (_) + (let ((menu (make-sparse-keymap))) + (if (fboundp 'context-menu-local) + (context-menu-local menu last-input-event) + (magit--context-menu-local menu last-input-event)) + (magit-section-context-menu menu last-input-event) + menu))))) + (keymap-set map " " #'magit-mouse-toggle-section) + (keymap-set map " " #'magit-mouse-toggle-section) + (keymap-set map "TAB" #'magit-section-toggle) + (keymap-set map "C-c TAB" #'magit-section-cycle) + (keymap-set map "C-" #'magit-section-cycle) + (keymap-set map "M-" #'magit-section-cycle) + ;; is the most portable binding for Shift+Tab. + (keymap-set map "" #'magit-section-cycle-global) + (keymap-set map "^" #'magit-section-up) + (keymap-set map "p" #'magit-section-backward) + (keymap-set map "n" #'magit-section-forward) + (keymap-set map "M-p" #'magit-section-backward-sibling) + (keymap-set map "M-n" #'magit-section-forward-sibling) + (keymap-set map "1" #'magit-section-show-level-1) + (keymap-set map "2" #'magit-section-show-level-2) + (keymap-set map "3" #'magit-section-show-level-3) + (keymap-set map "4" #'magit-section-show-level-4) + (keymap-set map "M-1" #'magit-section-show-level-1-all) + (keymap-set map "M-2" #'magit-section-show-level-2-all) + (keymap-set map "M-3" #'magit-section-show-level-3-all) + (keymap-set map "M-4" #'magit-section-show-level-4-all) + map) + "Parent keymap for all keymaps of modes derived from `magit-section-mode'.") + +(define-derived-mode magit-section-mode special-mode "Magit-Sections" + "Parent major mode from which major modes with Magit-like sections inherit. + +Magit-Section is documented in info node `(magit-section)'." + :interactive nil + :group 'magit-section + (buffer-disable-undo) + (setq truncate-lines t) + (setq buffer-read-only t) + (setq-local line-move-visual t) ; see #1771 + ;; Turn off syntactic font locking, but not by setting + ;; `font-lock-defaults' because that would enable font locking, and + ;; not all magit plugins may be ready for that (see #3950). + (setq-local font-lock-syntactic-face-function #'ignore) + (setq show-trailing-whitespace nil) + (setq-local symbol-overlay-inhibit-map t) + (setq list-buffers-directory (abbreviate-file-name default-directory)) + (make-local-variable 'text-property-default-nonsticky) + (push (cons 'keymap t) text-property-default-nonsticky) + (add-hook 'pre-command-hook #'magit-section-pre-command-hook nil t) + (add-hook 'post-command-hook #'magit-section-post-command-hook t t) + (add-hook 'deactivate-mark-hook #'magit-section-deactivate-mark t t) + (setq-local redisplay-highlight-region-function + #'magit-section--highlight-region) + (setq-local redisplay-unhighlight-region-function + #'magit-section--unhighlight-region) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'magit-section--remove-text-properties) + (when (fboundp 'magit-section-context-menu) + (add-hook 'context-menu-functions #'magit-section-context-menu 10 t)) + (when magit-section-disable-line-numbers + (when (and (fboundp 'linum-mode) + (bound-and-true-p global-linum-mode)) + (linum-mode -1)) + (when (and (fboundp 'nlinum-mode) + (bound-and-true-p global-nlinum-mode)) + (nlinum-mode -1)) + (when (and (fboundp 'display-line-numbers-mode) + (bound-and-true-p global-display-line-numbers-mode)) + (display-line-numbers-mode -1))) + (when (fboundp 'magit-preserve-section-visibility-cache) + (add-hook 'kill-buffer-hook #'magit-preserve-section-visibility-cache))) + +(defun magit-section--remove-text-properties (string) + "Remove all text-properties from STRING. +Most importantly `magit-section'." + (set-text-properties 0 (length string) nil string) + string) + +;;; Core + +(defvar-local magit-root-section nil + "The root section in the current buffer. +All other sections are descendants of this section. The value +of this variable is set by `magit-insert-section' and you should +never modify it.") +(put 'magit-root-section 'permanent-local t) + +(defvar-local magit--context-menu-section nil "For internal use only.") + +(defvar magit--context-menu-buffer nil "For internal use only.") + +(defun magit-point () + "Return point or the position where the context menu was invoked. +When using the context menu, return the position the user clicked +on, provided the current buffer is the buffer in which the click +occurred. Otherwise return the same value as `point'." + (if magit--context-menu-section + (magit-menu-position) + (point))) + +(defun magit-thing-at-point (thing &optional no-properties) + "Return the THING at point or where the context menu was invoked. +When using the context menu, return the thing the user clicked +on, provided the current buffer is the buffer in which the click +occurred. Otherwise return the same value as `thing-at-point'. +For the meaning of THING and NO-PROPERTIES see that function." + (if-let ((pos (magit-menu-position))) + (save-excursion + (goto-char pos) + (thing-at-point thing no-properties)) + (thing-at-point thing no-properties))) + +(defun magit-current-section () + "Return the section at point or where the context menu was invoked. +When using the context menu, return the section that the user +clicked on, provided the current buffer is the buffer in which +the click occurred. Otherwise return the section at point." + (or magit--context-menu-section + (magit-section-at) + magit-root-section)) + +(defun magit-section-at (&optional position) + "Return the section at POSITION, defaulting to point." + (get-text-property (or position (point)) 'magit-section)) + +(defun magit-section-ident (section) + "Return an unique identifier for SECTION. +The return value has the form ((TYPE . VALUE)...)." + (cons (cons (oref section type) + (magit-section-ident-value section)) + (and-let* ((parent (oref section parent))) + (magit-section-ident parent)))) + +(defun magit-section-equal (a b) + "Return t if A an B are the same section." + (and a b (equal (magit-section-ident a) + (magit-section-ident b)))) + +(cl-defgeneric magit-section-ident-value (object) + "Return OBJECT's value, making it constant and unique if necessary. + +This is used to correlate different incarnations of the same +section, see `magit-section-ident' and `magit-get-section'. + +Sections whose values are not constant and/or unique should +implement a method that return a value that can be used for +thispurpose.") + +(cl-defmethod magit-section-ident-value ((section magit-section)) + "Return the value unless it is an object. + +Different object incarnations representing the same value tend to +not be equal, so call this generic function on the object itself +to determine a constant value." + (let ((value (oref section value))) + (if (eieio-object-p value) + (magit-section-ident-value value) + value))) + +(cl-defmethod magit-section-ident-value ((object eieio-default-superclass)) + "For values that are objects, simply return the object itself. +Two objects that represent the same entity are not `equal'. So if +the values of the objects of a certain section class are themselves +objects, then a method has to be defined for objects of one of the +involved classes." + object) + +(defun magit-get-section (ident &optional root) + "Return the section identified by IDENT. +IDENT has to be a list as returned by `magit-section-ident'. +If optional ROOT is non-nil, then search in that section tree +instead of in the one whose root `magit-root-section' is." + (setq ident (reverse ident)) + (let ((section (or root magit-root-section))) + (when (eq (car (pop ident)) + (oref section type)) + (while (and ident + (pcase-let ((`(,type . ,value) (car ident))) + (setq section + (cl-find-if + (##and (eq (oref % type) type) + (equal (magit-section-ident-value %) value)) + (oref section children))))) + (pop ident)) + section))) + +(defun magit-section-lineage (section &optional raw) + "Return the lineage of SECTION. +If optional RAW is non-nil, return a list of section objects, beginning +with SECTION, otherwise return a list of section types." + (cons (if raw section (oref section type)) + (and-let* ((parent (oref section parent))) + (magit-section-lineage parent raw)))) + +(defvar-local magit-insert-section--current nil "For internal use only.") +(defvar-local magit-insert-section--parent nil "For internal use only.") +(defvar-local magit-insert-section--oldroot nil "For internal use only.") + +;;; Menu + +(defvar magit-menu-common-value nil "See function `magit-menu-common-value'.") +(defvar magit-menu--desc-values nil "For internal use only.") + +(defun magit-section-context-menu (menu click) + "Populate MENU with Magit-Section commands at CLICK." + (when-let ((section (save-excursion + (unless (region-active-p) + (mouse-set-point click)) + (magit-section-at)))) + (unless (region-active-p) + (setq magit--context-menu-buffer (current-buffer)) + (if-let ((alt (save-excursion + (mouse-set-point click) + (run-hook-with-args-until-success + 'magit-menu-alternative-section-hook section)))) + (setq magit--context-menu-section (setq section alt)) + (setq magit--context-menu-section section) + (magit-section-update-highlight t))) + (when (magit-section-content-p section) + (keymap-set-after menu "" + `(menu-item + ,(if (oref section hidden) "Expand section" "Collapse section") + magit-section-toggle)) + (when-let (((not (oref section hidden))) + (children (oref section children))) + (when (seq-some #'magit-section-content-p children) + (when (seq-some (##oref % hidden) children) + (keymap-set-after menu "" + `(menu-item "Expand children" + magit-section-show-children))) + (when (seq-some (##not (oref % hidden)) children) + (keymap-set-after menu "" + `(menu-item "Collapse children" + magit-section-hide-children))))) + (keymap-set-after menu "" menu-bar-separator)) + (keymap-set-after menu "" + `(menu-item "Describe section" magit-describe-section)) + (when-let ((map (oref section keymap))) + (keymap-set-after menu "" menu-bar-separator) + (when (symbolp map) + (setq map (symbol-value map))) + (setq magit-menu-common-value (magit-menu-common-value section)) + (setq magit-menu--desc-values (magit-menu--desc-values section)) + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (if (fboundp 'menu-bar-keymap) + (menu-bar-keymap map) + (magit--menu-bar-keymap map))))) + menu) + +(defun magit-menu-item (desc def &optional props) + "Return a menu item named DESC binding DEF and using PROPS. + +If DESC contains a supported %-spec, substitute the +expression (magit-menu-format-desc DESC) for that. +See `magit-menu-format-desc'." + `(menu-item + ,(if (and (stringp desc) (string-match-p "%[tTvsmMx]" desc)) + (list 'magit-menu-format-desc desc) + desc) + ,def + ;; Without this, the keys for point would be shown instead + ;; of the relevant ones from where the click occurred. + :keys ,(##magit--menu-position-keys def) + ,@props)) + +(defun magit--menu-position-keys (def) + (or (ignore-errors + (save-excursion + (goto-char (magit-menu-position)) + (and-let* ((key (cl-find-if-not + (lambda (key) + (string-match-p "\\`<[0-9]+>\\'" + (key-description key))) + (where-is-internal def)))) + (key-description key)))) + "")) + +(defun magit-menu-position () + "Return the position where the context-menu was invoked. +If the current command wasn't invoked using the context-menu, +then return nil." + (and magit--context-menu-section + (ignore-errors + (posn-point (event-start (aref (this-command-keys-vector) 0)))))) + +(defun magit-menu-highlight-point-section () + (setq magit-section-highlight-force-update t) + (if (eq (current-buffer) magit--context-menu-buffer) + (setq magit--context-menu-section nil) + (if-let ((window (get-buffer-window magit--context-menu-buffer))) + (with-selected-window window + (setq magit--context-menu-section nil) + (magit-section-update-highlight)) + (with-current-buffer magit--context-menu-buffer + (setq magit--context-menu-section nil)))) + (setq magit--context-menu-buffer nil)) + +(defvar magit--plural-append-es '(branch)) + +(cl-defgeneric magit-menu-common-value (_section) + "Return some value to be used by multiple menu items. +This function is called by `magit-section-context-menu', which +stores the value in `magit-menu-common-value'. Individual menu +items can use it, e.g., in the expression used to set their +description." + nil) + +(defun magit-menu--desc-values (section) + (let ((type (oref section type)) + (value (oref section value)) + (multiple (magit-region-sections nil t))) + (list type + value + (format "%s %s" type value) + (and multiple (length multiple)) + (if (memq type magit--plural-append-es) "es" "s")))) + +(defun magit-menu-format-desc (format) + "Format a string based on FORMAT and menu section or selection. +The following %-specs are allowed: +%t means \"TYPE\". +%T means \"TYPE\", or \"TYPEs\" if multiple sections are selected. +%v means \"VALUE\". +%s means \"TYPE VALUE\". +%m means \"TYPE VALUE\", or \"COUNT TYPEs\" if multiple sections + are selected. +%M means \"VALUE\", or \"COUNT TYPEs\" if multiple sections are + selected. +%x means the value of `magit-menu-common-value'." + (pcase-let* ((`(,type ,value ,single ,count ,suffix) magit-menu--desc-values) + (multiple (and count (format "%s %s%s" count type suffix)))) + (format-spec format + `((?t . ,type) + (?T . ,(format "%s%s" type (if count suffix ""))) + (?v . ,value) + (?s . ,single) + (?m . ,(or multiple single)) + (?M . ,(or multiple value)) + (?x . ,(format "%s" magit-menu-common-value)))))) + +(defun magit--menu-bar-keymap (keymap) + "Backport of `menu-bar-keymap' for Emacs < 28. +Slight trimmed down." + (let ((menu-bar nil)) + (map-keymap (lambda (key binding) + (push (cons key binding) menu-bar)) + keymap) + (cons 'keymap (nreverse menu-bar)))) + +(defun magit--context-menu-local (menu _click) + "Backport of `context-menu-local' for Emacs < 28." + (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) + (keymap-set-after menu "" menu-bar-separator) + (let ((keymap (local-key-binding [menu-bar]))) + (when keymap + (map-keymap (lambda (key binding) + (when (consp binding) + (define-key-after menu (vector key) + (copy-sequence binding)))) + (magit--menu-bar-keymap keymap)))) + menu) + +(define-advice context-menu-region (:around (fn menu click) magit-section-mode) + "Disable in `magit-section-mode' buffers." + (if (derived-mode-p 'magit-section-mode) + menu + (funcall fn menu click))) + +;;; Commands +;;;; Movement + +(defun magit-section-forward () + "Move to the beginning of the next visible section." + (interactive) + (if (eobp) + (user-error "No next section") + (let ((section (magit-current-section))) + (if (oref section parent) + (let ((next (and (not (oref section hidden)) + (not (= (oref section end) + (1+ (point)))) + (car (oref section children))))) + (while (and section (not next)) + (unless (setq next (car (magit-section-siblings section 'next))) + (setq section (oref section parent)))) + (if next + (magit-section-goto next) + (user-error "No next section"))) + (magit-section-goto 1))))) + +(defun magit-section-backward () + "Move to the beginning of the current or the previous visible section. +When point is at the beginning of a section then move to the +beginning of the previous visible section. Otherwise move to +the beginning of the current section." + (interactive) + (if (bobp) + (user-error "No previous section") + (let ((section (magit-current-section)) children) + (cond + ((and (= (point) + (1- (oref section end))) + (setq children (oref section children))) + (magit-section-goto (car (last children)))) + ((and (oref section parent) + (not (= (point) + (oref section start)))) + (magit-section-goto section)) + (t + (let ((prev (car (magit-section-siblings section 'prev)))) + (if prev + (while (and (not (oref prev hidden)) + (setq children (oref prev children))) + (setq prev (car (last children)))) + (setq prev (oref section parent))) + (cond (prev + (magit-section-goto prev)) + ((oref section parent) + (user-error "No previous section")) + ;; Eob special cases. + ((not (get-text-property (1- (point)) 'invisible)) + (magit-section-goto -1)) + (t + (goto-char (previous-single-property-change + (1- (point)) 'invisible)) + (forward-line -1) + (magit-section-goto (magit-current-section)))))))))) + +(defun magit-section-up () + "Move to the beginning of the parent section." + (interactive) + (if-let ((parent (oref (magit-current-section) parent))) + (magit-section-goto parent) + (user-error "No parent section"))) + +(defun magit-section-forward-sibling () + "Move to the beginning of the next sibling section. +If there is no next sibling section, then move to the parent." + (interactive) + (let ((current (magit-current-section))) + (if (oref current parent) + (if-let ((next (car (magit-section-siblings current 'next)))) + (magit-section-goto next) + (magit-section-forward)) + (magit-section-goto 1)))) + +(defun magit-section-backward-sibling () + "Move to the beginning of the previous sibling section. +If there is no previous sibling section, then move to the parent." + (interactive) + (let ((current (magit-current-section))) + (if (oref current parent) + (if-let ((previous (car (magit-section-siblings current 'prev)))) + (magit-section-goto previous) + (magit-section-backward)) + (magit-section-goto -1)))) + +(defun magit-mouse-set-point (event &optional promote-to-region) + "Like `mouse-set-point' but also call `magit-section-movement-hook'." + (interactive "e\np") + (mouse-set-point event promote-to-region) + (run-hook-with-args 'magit-section-movement-hook (magit-current-section))) + +(defun magit-section-goto (arg) + "Run `magit-section-movement-hook'. +See info node `(magit)Section Movement'." + (if (integerp arg) + (progn (forward-line arg) + (setq arg (magit-current-section))) + (goto-char (oref arg start))) + (run-hook-with-args 'magit-section-movement-hook arg)) + +(defun magit-section-set-window-start (section) + "Ensure the beginning of SECTION is visible." + (unless (pos-visible-in-window-p (oref section end)) + (set-window-start (selected-window) (oref section start)))) + +(defmacro magit-define-section-jumper + (name heading type &optional value inserter &rest properties) + "Define an interactive function to go some section. +Together TYPE and VALUE identify the section. +HEADING is the displayed heading of the section." + (declare (indent defun)) + `(transient-define-suffix ,name (&optional expand) + ,(format "Jump to the section \"%s\". +With a prefix argument also expand it." heading) + ,@properties + ,@(and (not (plist-member properties :description)) + (list :description heading)) + ,@(and inserter + `(:if (##memq ',inserter + (bound-and-true-p magit-status-sections-hook)))) + :inapt-if-not (##magit-get-section + (cons (cons ',type ,value) + (magit-section-ident magit-root-section))) + (interactive "P") + (if-let ((section (magit-get-section + (cons (cons ',type ,value) + (magit-section-ident magit-root-section))))) + (progn (goto-char (oref section start)) + (when expand + (with-local-quit (magit-section-show section)) + (recenter 0))) + (message ,(format "Section \"%s\" wasn't found" heading))))) + +;;;; Visibility + +(defun magit-section-show (section) + "Show the body of the current section." + (interactive (list (magit-current-section))) + (oset section hidden nil) + (magit-section--opportunistic-wash section) + (magit-section--opportunistic-paint section) + (when-let ((beg (oref section content))) + (remove-overlays beg (oref section end) 'invisible t)) + (magit-section-maybe-update-visibility-indicator section) + (magit-section-maybe-cache-visibility section) + (dolist (child (oref section children)) + (if (oref child hidden) + (magit-section-hide child) + (magit-section-show child)))) + +(defun magit-section-hide (section) + "Hide the body of the current section." + (interactive (list (magit-current-section))) + (if (eq section magit-root-section) + (user-error "Cannot hide root section") + (oset section hidden t) + (when-let ((beg (oref section content))) + (let ((end (oref section end))) + (when (< beg (point) end) + (goto-char (oref section start))) + (remove-overlays beg end 'invisible t) + (let ((o (make-overlay beg end))) + (overlay-put o 'evaporate t) + (overlay-put o 'invisible t) + (overlay-put o 'cursor-intangible t)))) + (magit-section-maybe-update-visibility-indicator section) + (magit-section-maybe-cache-visibility section))) + +(defun magit-section-toggle (section) + "Toggle visibility of the body of the current section." + (interactive (list (magit-current-section))) + (cond ((eq section magit-root-section) + (user-error "Cannot hide root section")) + ((oref section hidden) + (magit-section-show section)) + ((magit-section-hide section)))) + +(defun magit-section-toggle-children (section) + "Toggle visibility of bodies of children of the current section." + (interactive (list (magit-current-section))) + (let* ((children (oref section children)) + (show (seq-some (##oref % hidden) children))) + (dolist (c children) + (oset c hidden show))) + (magit-section-show section)) + +(defun magit-section-show-children (section &optional depth) + "Recursively show the bodies of children of the current section. +With a prefix argument show children that deep and hide deeper +children." + (interactive (list (magit-current-section))) + (magit-section-show-children-1 section depth) + (magit-section-show section)) + +(defun magit-section-show-children-1 (section &optional depth) + (dolist (child (oref section children)) + (oset child hidden nil) + (if depth + (if (> depth 0) + (magit-section-show-children-1 child (1- depth)) + (magit-section-hide child)) + (magit-section-show-children-1 child)))) + +(defun magit-section-hide-children (section) + "Recursively hide the bodies of children of the current section." + (interactive (list (magit-current-section))) + (mapc #'magit-section-hide (oref section children))) + +(defun magit-section-show-headings (section) + "Recursively show headings of children of the current section. +Only show the headings, previously shown text-only bodies are +hidden." + (interactive (list (magit-current-section))) + (magit-section-show-headings-1 section) + (magit-section-show section)) + +(defun magit-section-show-headings-1 (section) + (dolist (child (oref section children)) + (oset child hidden nil) + (when (or (oref child children) + (not (oref child content))) + (magit-section-show-headings-1 child)))) + +(defun magit-section-cycle (section) + "Cycle visibility of current section and its children. + +If this command is invoked using \\`C-' and that is globally bound +to `tab-next', then this command pivots to behave like that command, and +you must instead use \\`C-c TAB' to cycle section visibility. + +If you would like to keep using \\`C-' to cycle section visibility +but also want to use `tab-bar-mode', then you have to prevent that mode +from using this key and instead bind another key to `tab-next'. Because +`tab-bar-mode' does not use a mode map but instead manipulates the +global map, this involves advising `tab-bar--define-keys'." + (interactive (list (magit-current-section))) + (cond + ((and (equal (this-command-keys) [C-tab]) + (eq (global-key-binding [C-tab]) 'tab-next) + (fboundp 'tab-bar-switch-to-next-tab)) + (tab-bar-switch-to-next-tab current-prefix-arg)) + ((eq section magit-root-section) + (magit-section-cycle-global)) + ((oref section hidden) + (magit-section-show section) + (magit-section-hide-children section)) + ((let ((children (oref section children))) + (cond ((and (seq-some (##oref % hidden) children) + (seq-some (##oref % children) children)) + (magit-section-show-headings section)) + ((seq-some #'magit-section-hidden-body children) + (magit-section-show-children section)) + ((magit-section-hide section))))))) + +(defun magit-section-cycle-global () + "Cycle visibility of all sections in the current buffer." + (interactive) + (let ((children (oref magit-root-section children))) + (cond ((and (seq-some (##oref % hidden) children) + (seq-some (##oref % children) children)) + (magit-section-show-headings magit-root-section)) + ((seq-some #'magit-section-hidden-body children) + (magit-section-show-children magit-root-section)) + (t + (mapc #'magit-section-hide children))))) + +(defun magit-section-hidden (section) + "Return t if SECTION and/or an ancestor is hidden." + (or (oref section hidden) + (and-let* ((parent (oref section parent))) + (magit-section-hidden parent)))) + +(defun magit-section-hidden-body (section &optional pred) + "Return t if the content of SECTION or of any children is hidden." + (if-let ((children (oref section children))) + (funcall (or pred #'seq-some) #'magit-section-hidden-body children) + (and (oref section content) + (oref section hidden)))) + +(defun magit-section-content-p (section) + "Return non-nil if SECTION has content or an unused washer function." + (with-slots (content end washer) section + (and content (or (not (= content end)) washer)))) + +(defun magit-section-invisible-p (section) + "Return t if the SECTION's body is invisible. +When the body of an ancestor of SECTION is collapsed then +SECTION's body (and heading) obviously cannot be visible." + (or (oref section hidden) + (and-let* ((parent (oref section parent))) + (magit-section-invisible-p parent)))) + +(defun magit-section-show-level (level) + "Show surrounding sections up to LEVEL. +Likewise hide sections at higher levels. If the region selects multiple +sibling sections, act on all marked trees. If LEVEL is negative, show +all sections up to the absolute value of that, not just surrounding +sections." + (if (< level 0) + (let ((s (magit-current-section))) + (setq level (- level)) + (while (> (1- (length (magit-section-ident s))) level) + (setq s (oref s parent)) + (goto-char (oref s start))) + (magit-section-show-children magit-root-section (1- level))) + (dolist (section (or (magit-region-sections) + (list (magit-current-section)))) + (cl-do* ((s section + (oref s parent)) + (i (1- (length (magit-section-ident s))) + (cl-decf i))) + ((cond ((< i level) (magit-section-show-children s (- level i 1)) t) + ((= i level) (magit-section-hide s) t)) + (magit-section-goto s)))))) + +(defun magit-section-show-level-1 () + "Show surrounding sections on first level." + (interactive) + (magit-section-show-level 1)) + +(defun magit-section-show-level-1-all () + "Show all sections on first level." + (interactive) + (magit-section-show-level -1)) + +(defun magit-section-show-level-2 () + "Show surrounding sections up to second level." + (interactive) + (magit-section-show-level 2)) + +(defun magit-section-show-level-2-all () + "Show all sections up to second level." + (interactive) + (magit-section-show-level -2)) + +(defun magit-section-show-level-3 () + "Show surrounding sections up to third level." + (interactive) + (magit-section-show-level 3)) + +(defun magit-section-show-level-3-all () + "Show all sections up to third level." + (interactive) + (magit-section-show-level -3)) + +(defun magit-section-show-level-4 () + "Show surrounding sections up to fourth level." + (interactive) + (magit-section-show-level 4)) + +(defun magit-section-show-level-4-all () + "Show all sections up to fourth level." + (interactive) + (magit-section-show-level -4)) + +(defun magit-mouse-toggle-section (event) + "Toggle visibility of the clicked section. +Clicks outside either the section heading or the left fringe are +silently ignored." + (interactive "e") + (let* ((pos (event-start event)) + (section (magit-section-at (posn-point pos)))) + (if (eq (posn-area pos) 'left-fringe) + (when section + (while (not (magit-section-content-p section)) + (setq section (oref section parent))) + (unless (eq section magit-root-section) + (goto-char (oref section start)) + (magit-section-toggle section))) + (magit-section-toggle section)))) + +;;;; Auxiliary + +(defun magit-describe-section-briefly (section &optional ident interactive) + "Show information about the section at point. +With a prefix argument show the section identity instead of the +section lineage. This command is intended for debugging purposes. +\n(fn SECTION &optional IDENT)" + (interactive (list (magit-current-section) current-prefix-arg t)) + (let ((str (format "#<%s %S %S %s-%s%s>" + (eieio-object-class section) + (let ((val (oref section value))) + (cond ((stringp val) + (substring-no-properties val)) + ((and (eieio-object-p val) + (fboundp 'cl-prin1-to-string)) + (cl-prin1-to-string val)) + (t + val))) + (if ident + (magit-section-ident section) + (apply #'vector (magit-section-lineage section))) + (and-let* ((m (oref section start))) + (if (markerp m) (marker-position m) m)) + (if-let ((m (oref section content))) + (format "[%s-]" + (if (markerp m) (marker-position m) m)) + "") + (and-let* ((m (oref section end))) + (if (markerp m) (marker-position m) m))))) + (when interactive + (message "%s" str)) + str)) + +(cl-defmethod cl-print-object ((section magit-section) stream) + "Print `magit-describe-section' result of SECTION." + (princ (magit-describe-section-briefly section) stream)) + +(defun magit-describe-section (section &optional interactive-p) + "Show information about the section at point." + (interactive (list (magit-current-section) t)) + (let ((inserter-section section)) + (while (and inserter-section (not (oref inserter-section inserter))) + (setq inserter-section (oref inserter-section parent))) + (when (and inserter-section (oref inserter-section inserter)) + (setq section inserter-section))) + (pcase (oref section inserter) + (`((,hook ,fun) . ,src-src) + (help-setup-xref `(magit-describe-section ,section) interactive-p) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert (format-message + "%s\n is inserted by `%s'\n from `%s'" + (magit-describe-section-briefly section) + (make-text-button (symbol-name fun) nil + :type 'help-function + 'help-args (list fun)) + (make-text-button (symbol-name hook) nil + :type 'help-variable + 'help-args (list hook)))) + (pcase-dolist (`(,hook ,fun) src-src) + (insert (format-message + ",\n called by `%s'\n from `%s'" + (make-text-button (symbol-name fun) nil + :type 'help-function + 'help-args (list fun)) + (make-text-button (symbol-name hook) nil + :type 'help-variable + 'help-args (list hook))))) + (insert ".\n\n") + (insert + (format-message + "`%s' is " + (make-text-button (symbol-name fun) nil + :type 'help-function 'help-args (list fun)))) + (describe-function-1 fun)))) + (_ (message "%s, inserter unknown" + (magit-describe-section-briefly section))))) + +;;; Match + +(cl-defun magit-section-match + (condition &optional (section (magit-current-section))) + "Return t if SECTION matches CONDITION. + +SECTION defaults to the section at point. If SECTION is not +specified and there also is no section at point, then return +nil. + +CONDITION can take the following forms: + (CONDITION...) matches if any of the CONDITIONs matches. + [CLASS...] matches if the section's class is the same + as the first CLASS or a subclass of that; + the section's parent class matches the + second CLASS; and so on. + [* CLASS...] matches sections that match [CLASS...] and + also recursively all their child sections. + CLASS matches if the section's class is the same + as CLASS or a subclass of that; regardless + of the classes of the parent sections. + +Each CLASS should be a class symbol, identifying a class that +derives from `magit-section'. For backward compatibility CLASS +can also be a \"type symbol\". A section matches such a symbol +if the value of its `type' slot is `eq'. If a type symbol has +an entry in `magit--section-type-alist', then a section also +matches that type if its class is a subclass of the class that +corresponds to the type as per that alist. + +Note that it is not necessary to specify the complete section +lineage as printed by `magit-describe-section-briefly', unless +of course you want to be that precise." + (and section (magit-section-match-1 condition section))) + +(defun magit-section-match-1 (condition section) + (cl-assert condition) + (and section + (if (listp condition) + (seq-find (##magit-section-match-1 % section) condition) + (magit-section-match-2 (if (symbolp condition) + (list condition) + (cl-coerce condition 'list)) + section)))) + +(defun magit-section-match-2 (condition section) + (if (eq (car condition) '*) + (or (magit-section-match-2 (cdr condition) section) + (and-let* ((parent (oref section parent))) + (magit-section-match-2 condition parent))) + (and (let ((c (car condition))) + (if (class-p c) + (cl-typep section c) + (if-let ((class (cdr (assq c magit--section-type-alist)))) + (cl-typep section class) + (eq (oref section type) c)))) + (or (not (setq condition (cdr condition))) + (and-let* ((parent (oref section parent))) + (magit-section-match-2 condition parent)))))) + +(defun magit-section-value-if (condition &optional section) + "If the section at point matches CONDITION, then return its value. + +If optional SECTION is non-nil then test whether that matches +instead. If there is no section at point and SECTION is nil, +then return nil. If the section does not match, then return +nil. + +See `magit-section-match' for the forms CONDITION can take." + (and-let* ((section (or section (magit-current-section)))) + (and (magit-section-match condition section) + (oref section value)))) + +(defmacro magit-section-case (&rest clauses) + "Choose among clauses on the type of the section at point. + +Each clause looks like (CONDITION BODY...). The type of the +section is compared against each CONDITION; the BODY forms of the +first match are evaluated sequentially and the value of the last +form is returned. Inside BODY the symbol `it' is bound to the +section at point. If no clause succeeds or if there is no +section at point, return nil. + +See `magit-section-match' for the forms CONDITION can take. +Additionally a CONDITION of t is allowed in the final clause, and +matches if no other CONDITION match, even if there is no section +at point." + (declare (indent 0) + (debug (&rest (sexp body)))) + `(let* ((it (magit-current-section))) + (cond ,@(mapcar (lambda (clause) + `(,(or (eq (car clause) t) + `(and it + (magit-section-match-1 ',(car clause) it))) + ,@(cdr clause))) + clauses)))) + +(defun magit-section-match-assoc (section alist) + "Return the value associated with SECTION's type or lineage in ALIST." + (seq-some (pcase-lambda (`(,key . ,val)) + (and (magit-section-match-1 key section) val)) + alist)) + +;;; Create + +(defvar magit-insert-section-hook nil + "Hook run after `magit-insert-section's BODY. +Avoid using this hook and only ever do so if you know +what you are doing and are sure there is no other way.") + +(defmacro magit-insert-section (&rest args) + "Insert a section at point. + +Create a section object of type CLASS, storing VALUE in its +`value' slot, and insert the section at point. CLASS is a +subclass of `magit-section' or has the form `(eval FORM)', in +which case FORM is evaluated at runtime and should return a +subclass. In other places a sections class is often referred +to as its \"type\". + +Many commands behave differently depending on the class of the +current section and sections of a certain class can have their +own keymap, which is specified using the `keymap' class slot. +The value of that slot should be a variable whose value is a +keymap. + +For historic reasons Magit and Forge in most cases use symbols +as CLASS that don't actually identify a class and that lack the +appropriate package prefix. This works due to some undocumented +kludges, which are not available to other packages. + +When optional HIDE is non-nil collapse the section body by +default, i.e., when first creating the section, but not when +refreshing the buffer. Else expand it by default. This can be +overwritten using `magit-section-set-visibility-hook'. When a +section is recreated during a refresh, then the visibility of +predecessor is inherited and HIDE is ignored (but the hook is +still honored). + +BODY is any number of forms that actually insert the section's +heading and body. Optional NAME, if specified, has to be a +symbol, which is then bound to the object of the section being +inserted. + +Before BODY is evaluated the `start' of the section object is set +to the value of `point' and after BODY was evaluated its `end' is +set to the new value of `point'; BODY is responsible for moving +`point' forward. + +If it turns out inside BODY that the section is empty, then +`magit-cancel-section' can be used to abort and remove all traces +of the partially inserted section. This can happen when creating +a section by washing Git's output and Git didn't actually output +anything this time around. + +\(fn [NAME] (CLASS &optional VALUE HIDE) &rest BODY)" + (declare (indent 1) ;sic + (debug ([&optional symbolp] + (&or [("eval" form) &optional form form &rest form] + [symbolp &optional form form &rest form]) + body))) + (pcase-let* ((bind (and (symbolp (car args)) + (pop args))) + (`((,class ,value ,hide . ,args) . ,body) args) + (obj (gensym "section"))) + `(let* ((,obj (magit-insert-section--create + ,(if (eq (car-safe class) 'eval) (cadr class) `',class) + ,value ,hide ,@args)) + (magit-insert-section--current ,obj) + (magit-insert-section--oldroot + (or magit-insert-section--oldroot + (and (not magit-insert-section--parent) + (prog1 magit-root-section + (setq magit-root-section ,obj))))) + (magit-insert-section--parent ,obj)) + (catch 'cancel-section + ,@(if bind `((let ((,bind ,obj)) ,@body)) body) + (magit-insert-section--finish ,obj)) + ,obj))) + +(defun magit-insert-section--create (class value hide &rest args) + (let (type) + (if (class-p class) + (setq type (or (car (rassq class magit--section-type-alist)) + class)) + (setq type class) + (setq class (or (cdr (assq class magit--section-type-alist)) + 'magit-section))) + (let ((obj (apply class :type type args))) + (oset obj value value) + (oset obj parent magit-insert-section--parent) + (oset obj start (if magit-section-inhibit-markers (point) (point-marker))) + (unless (slot-boundp obj 'hidden) + (oset obj hidden + (let (set old) + (cond + ((setq set (run-hook-with-args-until-success + 'magit-section-set-visibility-hook obj)) + (eq set 'hide)) + ((setq old (and (not magit-section-preserve-visibility) + magit-insert-section--oldroot + (magit-get-section + (magit-section-ident obj) + magit-insert-section--oldroot))) + (oref old hidden)) + ((setq set (magit-section-match-assoc + obj magit-section-initial-visibility-alist)) + (eq (if (functionp set) (funcall set obj) set) 'hide)) + (hide))))) + (unless (oref obj keymap) + (let ((type (oref obj type))) + (oset obj keymap + (or (let ((sym (intern (format "magit-%s-section-map" type)))) + (and (boundp sym) sym)) + (let ((sym (intern (format "forge-%s-section-map" type)))) + (and (boundp sym) sym)))))) + obj))) + +(defun magit-insert-section--finish (obj) + (run-hooks 'magit-insert-section-hook) + (if magit-section-inhibit-markers + (oset obj end (point)) + (oset obj end (point-marker)) + (set-marker-insertion-type (oref obj start) t)) + (cond + ((eq obj magit-root-section) + (when (eq magit-section-inhibit-markers 'delay) + (setq magit-section-inhibit-markers nil) + (magit-map-sections + (lambda (section) + (oset section start (copy-marker (oref section start) t)) + (oset section end (copy-marker (oref section end) t)))))) + (t + (magit-section--set-section-properties obj) + (magit-section-maybe-add-heading-map obj) + (when (oref obj children) + (magit-insert-child-count obj)) + (if magit-section-insert-in-reverse + (push obj (oref (oref obj parent) children)) + (let ((parent (oref obj parent))) + (oset parent children + (nconc (oref parent children) + (list obj))))))) + (when magit-section-insert-in-reverse + (oset obj children (nreverse (oref obj children))))) + +(defun magit-cancel-section (&optional if-empty) + "Cancel inserting the section that is currently being inserted. + +Canceling returns from the inner most use of `magit-insert-section' and +removes all text that was inserted by that. + +If optional IF-EMPTY is non-nil, then only cancel the section, if it is +empty. If a section is split into a heading and a body (i.e., when its +`content' slot is non-nil), then only check if the body is empty." + (when (and magit-insert-section--current + (or (not if-empty) + (= (point) (or (oref magit-insert-section--current content) + (oref magit-insert-section--current start))))) + (if (eq magit-insert-section--current magit-root-section) + (insert "(empty)\n") + (delete-region (oref magit-insert-section--current start) + (point)) + (setq magit-insert-section--current nil) + (throw 'cancel-section nil)))) + +(defun magit-insert-heading (&rest args) + "Insert the heading for the section currently being inserted. + +This function should only be used inside `magit-insert-section'. + +When called without any arguments, then just set the `content' +slot of the object representing the section being inserted to +a marker at `point'. The section should only contain a single +line when this function is used like this. + +When called with arguments ARGS, which have to be strings, or +nil, then insert those strings at point. The section should not +contain any text before this happens and afterwards it should +again only contain a single line. If the `face' property is set +anywhere inside any of these strings, then insert all of them +unchanged. Otherwise use the `magit-section-heading' face for +all inserted text. + +The `content' property of the section object is the end of the +heading (which lasts from `start' to `content') and the beginning +of the the body (which lasts from `content' to `end'). If the +value of `content' is nil, then the section has no heading and +its body cannot be collapsed. If a section does have a heading, +then its height must be exactly one line, including a trailing +newline character. This isn't enforced, you are responsible for +getting it right. The only exception is that this function does +insert a newline character if necessary + +If provided, optional CHILD-COUNT must evaluate to an integer or +boolean. If t, then the count is determined once the children have been +inserted, using `magit-insert-child-count' (which see). For historic +reasons, if the heading ends with \":\", the count is substituted for +that, at this time as well. If `magit-section-show-child-count' is nil, +no counts are inserted + +\n(fn [CHILD-COUNT] &rest STRINGS)" + (declare (indent defun)) + (when args + (let ((count (and (or (integerp (car args)) + (booleanp (car args))) + (pop args))) + (heading (apply #'concat args))) + (insert (if (or (text-property-not-all 0 (length heading) + 'font-lock-face nil heading) + (text-property-not-all 0 (length heading) + 'face nil heading)) + heading + (propertize heading 'font-lock-face 'magit-section-heading))) + (when (and count magit-section-show-child-count) + (insert (propertize (format " (%s)" count) + 'font-lock-face 'magit-section-child-count))))) + (unless (bolp) + (insert ?\n)) + (when (fboundp 'magit-maybe-make-margin-overlay) + (magit-maybe-make-margin-overlay)) + (oset magit-insert-section--current content + (if magit-section-inhibit-markers (point) (point-marker)))) + +(defmacro magit-insert-section-body (&rest body) + "Use BODY to insert the section body, once the section is expanded. +If the section is expanded when it is created, then this is +like `progn'. Otherwise BODY isn't evaluated until the section +is explicitly expanded." + (declare (indent 0)) + (let ((f (gensym)) + (s (gensym)) + (l (gensym))) + `(let ((,f (lambda () ,@body))) + (if (oref magit-insert-section--current hidden) + (oset magit-insert-section--current washer + (let ((,s magit-insert-section--current)) + (lambda () + (let ((,l (magit-section-lineage ,s t))) + (dolist (s ,l) + (set-marker-insertion-type (oref s end) t)) + (funcall ,f) + (dolist (s ,l) + (set-marker-insertion-type (oref s end) nil)) + (magit-section--set-section-properties ,s) + (magit-section-maybe-remove-heading-map ,s) + (magit-section-maybe-remove-visibility-indicator ,s))))) + (funcall ,f))))) + +(defun magit-insert-headers (hook) + (let* ((header-sections nil) + (fn (##push magit-insert-section--current header-sections))) + (unwind-protect + (progn + (add-hook 'magit-insert-section-hook fn -90 t) + (magit-run-section-hook hook) + (when header-sections + (insert "\n") + ;; Make the first header into the parent of the rest. + (when (cdr header-sections) + (setq header-sections (nreverse header-sections)) + (let* ((1st-header (pop header-sections)) + (header-parent (oref 1st-header parent))) + (oset header-parent children (list 1st-header)) + (oset 1st-header children header-sections) + (oset 1st-header content (oref (car header-sections) start)) + (oset 1st-header end (oref (car (last header-sections)) end)) + (dolist (sub-header header-sections) + (oset sub-header parent 1st-header)) + (magit-section-maybe-add-heading-map 1st-header))))) + (remove-hook 'magit-insert-section-hook fn t)))) + +(defun magit-section--set-section-properties (section) + (pcase-let* (((eieio start end children keymap) section) + (props `( magit-section ,section + ,@(and-let* ((map (symbol-value keymap))) + (list 'keymap map))))) + (if children + (save-excursion + (goto-char start) + (while (< (point) end) + (let ((next (or (next-single-property-change (point) 'magit-section) + end))) + (unless (magit-section-at) + (add-text-properties (point) next props)) + (goto-char next)))) + (add-text-properties start end props)))) + +(defun magit-section-maybe-add-heading-map (section) + (when (magit-section-content-p section) + (let ((start (oref section start)) + (map (oref section keymap))) + (when (symbolp map) + (setq map (symbol-value map))) + (put-text-property + start + (magit--eol-position start) + 'keymap (if map + (make-composed-keymap + (list map magit-section-heading-map)) + magit-section-heading-map))))) + +(defun magit-section-maybe-remove-heading-map (section) + (with-slots (start content end keymap) section + (when (= content end) + (put-text-property start end 'keymap + (if (symbolp keymap) (symbol-value keymap) keymap))))) + +(defun magit-insert-child-count (section) + "Modify SECTION's heading to contain number of child sections. + +If `magit-section-show-child-count' is non-nil and the SECTION +has children and its heading ends with \":\", then replace that +with \" (N)\", where N is the number of child sections. + +This function is called by `magit-insert-section' after that has +evaluated its BODY. Admittedly that's a bit of a hack." + (let (content count) + (cond + ((not (and magit-section-show-child-count + (setq content (oref section content)) + (setq count (length (oref section children))) + (> count 0)))) + ((eq (char-before (- content 1)) ?:) + (save-excursion + (goto-char (- content 2)) + (insert (magit--propertize-face (format " (%s)" count) + 'magit-section-child-count)) + (delete-char 1))) + ((and (eq (char-before (- content 4)) ?\s) + (eq (char-before (- content 3)) ?\() + (eq (char-before (- content 2)) ?t ) + (eq (char-before (- content 1)) ?\))) + (save-excursion + (goto-char (- content 3)) + (delete-char 1) + (insert (format "%s" count))))))) + +(defun magit-section--opportunistic-wash (section) + (when-let ((washer (oref section washer))) + (oset section washer nil) + (let ((inhibit-read-only t) + (magit-insert-section--parent section) + (magit-insert-section--current section)) + (save-excursion + (goto-char (oref section end)) + (oset section content (point-marker)) + (funcall washer) + (oset section end (point-marker)))) + (setq magit-section-highlight-force-update t))) + +;;; Highlight + +(defvar magit-section--refreshed-buffers nil) + +(defun magit-section-pre-command-hook () + (when (and (or magit--context-menu-buffer + magit--context-menu-section) + (not (eq (ignore-errors + (event-basic-type (aref (this-command-keys) 0))) + 'mouse-3))) + ;; This is the earliest opportunity to clean up after an aborted + ;; context-menu because that neither causes the command that created + ;; the menu to abort nor some abortion hook to be run. It is not + ;; possible to update highlighting before the first command invoked + ;; after the menu is aborted. Here we can only make sure it is + ;; updated afterwards. + (magit-menu-highlight-point-section)) + (setq magit-section--refreshed-buffers nil) + (setq magit-section-pre-command-region-p (region-active-p)) + (setq magit-section-pre-command-section (magit-current-section)) + (setq magit-section-focused-sections nil)) + +(defun magit-section-post-command-hook () + (let ((window (selected-window))) + ;; The command may have used `set-window-buffer' to change + ;; the window's buffer without changing the current buffer. + (when (eq (current-buffer) (window-buffer window)) + (cursor-sensor-move-to-tangible window) + (when (or magit--context-menu-buffer + magit--context-menu-section) + (magit-menu-highlight-point-section)))) + (unless (memq (current-buffer) magit-section--refreshed-buffers) + (magit-section-update-highlight)) + (setq magit-section--refreshed-buffers nil)) + +(defun magit-section-deactivate-mark () + (setq magit-section-highlight-force-update t)) + +(defun magit-section-update-highlight (&optional force) + (let ((section (magit-current-section)) + (focused (magit-focused-sections))) + (cond + ((or force + magit-section-highlight-force-update + (xor magit-section-pre-command-region-p (region-active-p)) + (not (eq magit-section-pre-command-section section))) + (let ((inhibit-read-only t) + (deactivate-mark nil) + (selection (magit-region-sections))) + (mapc #'delete-overlay magit-section-highlight-overlays) + (mapc #'delete-overlay magit-section-selection-overlays) + (setq magit-section-highlight-overlays nil) + (setq magit-section-selection-overlays nil) + (cond ((magit-section--maybe-enable-long-lines-shortcuts)) + ((eq section magit-root-section)) + ((not magit-section-highlight-current) + (when selection + (magit-section-highlight-selection selection))) + ((not selection) + (magit-section-highlight section)) + (t + (mapc #'magit-section-highlight selection) + (magit-section-highlight-selection selection))) + (dolist (section (cl-union magit-section-highlighted-sections focused)) + (when (slot-boundp section 'painted) + (magit-section-update-paint section focused))) + (restore-buffer-modified-p nil))) + ((and (eq magit-section-pre-command-section section) + magit-section-selection-overlays + (region-active-p) + (not (magit-region-sections))) + (mapc #'delete-overlay magit-section-selection-overlays) + (setq magit-section-selection-overlays nil))) + (setq magit-section-highlight-force-update nil) + (magit-section-maybe-paint-visibility-ellipses))) + +(cl-defmethod magit-section-highlight ((section magit-section)) + (pcase-let* + (((eieio start content end children heading-highlight-face) section) + (headlight heading-highlight-face) + (selective (magit-section-selective-highlight-p section))) + (cond + (selective + (magit-section-highlight-range start (or content end) headlight) + (cond (children + (let ((child-start (oref (car children) start))) + (when (and content (< content child-start)) + (magit-section-highlight-range content child-start))) + (mapc #'magit-section-highlight children)) + ((and content (not (slot-boundp section 'painted))) + (magit-section-highlight-range content end)) + ;; Unfortunate kludge for delayed hunk refinement. + ((magit-section--refine section)))) + (headlight + (magit-section-highlight-range start (or content end) headlight) + (when content + (magit-section-highlight-range (if headlight content start) end))) + ((magit-section-highlight-range start end))))) + +(defun magit-section-highlight-selection (selection) + (when magit-section-highlight-selection + (dolist (sibling selection) + (with-slots (start content end heading-selection-face) sibling + (let ((ov (make-overlay start (or content end) nil t))) + (overlay-put ov 'font-lock-face + (or heading-selection-face + 'magit-section-heading-selection)) + (overlay-put ov 'evaporate t) + (overlay-put ov 'priority '(nil . 9)) + (push ov magit-section-selection-overlays) + ov))))) + +(defun magit-section-highlight-range (start end &optional face) + (let ((ov (make-overlay start end nil t))) + (overlay-put ov 'font-lock-face (or face 'magit-section-highlight)) + (overlay-put ov 'evaporate t) + (push ov magit-section-highlight-overlays) + ov)) + +(defun magit-section-selective-highlight-p (section &optional as-child) + (or (oref section selective-highlight) + (and as-child + (oref section heading-highlight-face)) + (slot-boundp section 'painted) + (and-let* ((children (oref section children))) + (magit-section-selective-highlight-p (car children) t)))) + +;;; Paint + +(defun magit-section-update-paint (section focused-sections) + (cl-flet ((paint (highlight) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (oref section start)) + (magit-section-paint section highlight)))) + (unregister () + (setq magit-section-highlighted-sections + (delq section magit-section-highlighted-sections)))) + (if (magit-section-hidden section) + ;; If the section is highlighted but unfocused, it remains + ;; highlighted, but `magit-section--opportunistic-paint' via + ;; `magit-section-show' will unhighlight on expansion, and + ;; before then (or if a refresh occurs first) it doesn't matter. + (unregister) + (pcase (list (if (memq section focused-sections) 'focus 'unfocus) + (oref section painted)) + (`(focus ,(or 'nil 'plain)) + (paint t) + (cl-pushnew section magit-section-highlighted-sections)) + (`(focus highlight) + (cl-pushnew section magit-section-highlighted-sections)) + (`(unfocus ,(or 'nil 'highlight)) + (paint nil) + (unregister)) + ('(unfocus plain) + (unregister)))))) + +(cl-defmethod magit-section-paint ((section magit-section) _highlight) + (error "Slot `paint' bound but `magit-section-paint' not implemented for `%s'" + (eieio-object-class-name section))) + +(defun magit-section--opportunistic-paint (section) + (when (and (not (oref section hidden)) + (slot-boundp section 'painted)) + (if magit--refreshing-buffer-p + ;; Defer to `magit-section-update-highlight'. + (unless (oref section painted) + (cl-pushnew section magit-section-highlighted-sections)) + (magit-section-update-paint section (magit-focused-sections))))) + +(cl-defmethod magit-section--refine ((_section magit-section))) + +;;; Long Lines + +(defvar magit-show-long-lines-warning t) + +(defun magit-section--maybe-enable-long-lines-shortcuts () + (and (fboundp 'long-line-optimizations-p) + (long-line-optimizations-p) + (prog1 t + (message "Enabling long lines shortcuts in %S" (current-buffer)) + (kill-local-variable 'redisplay-highlight-region-function) + (kill-local-variable 'redisplay-unhighlight-region-function) + (when magit-show-long-lines-warning + (setq magit-show-long-lines-warning nil) + (display-warning 'magit (format "\ +Emacs has enabled redisplay shortcuts +in this buffer because there are lines whose length go beyond +`long-line-threshold' (%s characters). As a result, section +highlighting and the special appearance of the region has been +disabled. + +These shortcuts remain enabled, even once there no longer are +any long lines in this buffer. To disable them again, kill +and recreate the buffer. + +This message won't be shown for this session again. To disable +it for all future sessions, set `magit-show-long-lines-warning' +to nil." (bound-and-true-p long-line-threshold)) :warning))))) + +;;; Successor + +(cl-defgeneric magit-section-get-relative-position (section)) + +(cl-defmethod magit-section-get-relative-position ((section magit-section)) + (let ((start (oref section start)) + (point (magit-point))) + (list (- (line-number-at-pos point) + (line-number-at-pos start)) + (- point (line-beginning-position))))) + +(cl-defgeneric magit-section-goto-successor ()) + +(cl-defmethod magit-section-goto-successor ((section magit-section) + line char &optional _arg) + (or (magit-section-goto-successor--same section line char) + (magit-section-goto-successor--related section))) + +(defun magit-section-goto-successor--same (section line char) + (let ((ident (magit-section-ident section))) + (and-let* ((found (magit-get-section ident))) + (let ((start (oref found start))) + (goto-char start) + (unless (eq found magit-root-section) + (ignore-errors + (forward-line line) + (forward-char char)) + (unless (eq (magit-current-section) found) + (goto-char start))) + t)))) + +(defun magit-section-goto-successor--related (section) + (and-let* ((found (magit-section-goto-successor--related-1 section))) + (goto-char (if (eq (oref found type) 'button) + (point-min) + (oref found start))))) + +(defun magit-section-goto-successor--related-1 (section) + (or (and-let* ((alt (pcase (oref section type) + ('staged 'unstaged) + ('unstaged 'staged) + ('unpushed 'unpulled) + ('unpulled 'unpushed)))) + (magit-get-section `((,alt) (status)))) + (and-let* ((next (car (magit-section-siblings section 'next)))) + (magit-get-section (magit-section-ident next))) + (and-let* ((prev (car (magit-section-siblings section 'prev)))) + (magit-get-section (magit-section-ident prev))) + (and-let* ((parent (oref section parent))) + (or (magit-get-section (magit-section-ident parent)) + (magit-section-goto-successor--related-1 parent))))) + +;;; Region + +(defvar-local magit-section--region-overlays nil) + +(defun magit-section--delete-region-overlays () + (mapc #'delete-overlay magit-section--region-overlays) + (setq magit-section--region-overlays nil)) + +(defun magit-section--highlight-region (start end window rol) + (magit-section--delete-region-overlays) + (if (and magit-section-highlight-selection + (not magit-section-keep-region-overlay) + (or (magit-region-sections) + (run-hook-with-args-until-success 'magit-region-highlight-hook + (magit-current-section))) + (not (= (line-number-at-pos start) + (line-number-at-pos end))) + ;; (not (eq (car-safe last-command-event) 'mouse-movement)) + ) + (funcall (default-value 'redisplay-unhighlight-region-function) rol) + (funcall (default-value 'redisplay-highlight-region-function) + start end window rol))) + +(defun magit-section--unhighlight-region (rol) + (magit-section--delete-region-overlays) + (funcall (default-value 'redisplay-unhighlight-region-function) rol)) + +;;; Visibility + +(defvar-local magit-section-visibility-cache nil) +(put 'magit-section-visibility-cache 'permanent-local t) + +(defun magit-section-cached-visibility (section) + "Return the visibility cached for SECTION. +When `magit-section-preserve-visibility' is nil, return nil." + (and magit-section-preserve-visibility + (cdr (assoc (magit-section-ident section) + magit-section-visibility-cache)))) + +(cl-defun magit-section-cache-visibility + (&optional (section magit-insert-section--current)) + "Cache SECTION's current visibility." + (setf (compat-call alist-get + (magit-section-ident section) + magit-section-visibility-cache + nil nil #'equal) + (if (oref section hidden) 'hide 'show))) + +(cl-defun magit-section-maybe-cache-visibility + (&optional (section magit-insert-section--current)) + (when (or (eq magit-section-cache-visibility t) + (memq (oref section type) + magit-section-cache-visibility)) + (magit-section-cache-visibility section))) + +(defun magit-section-maybe-update-visibility-indicator (section) + (when (and magit-section-visibility-indicator + (magit-section-content-p section)) + (let* ((beg (oref section start)) + (eoh (magit--eol-position beg))) + (cond + ((symbolp (car-safe magit-section-visibility-indicator)) + (let ((ov (magit--overlay-at beg 'magit-vis-indicator 'fringe))) + (unless ov + (setq ov (make-overlay beg eoh nil t)) + (overlay-put ov 'evaporate t) + (overlay-put ov 'magit-vis-indicator 'fringe)) + (overlay-put + ov 'before-string + (propertize "fringe" 'display + (list 'left-fringe + (if (oref section hidden) + (car magit-section-visibility-indicator) + (cdr magit-section-visibility-indicator)) + 'fringe))))) + ((stringp (car-safe magit-section-visibility-indicator)) + (let ((ov (magit--overlay-at (1- eoh) 'magit-vis-indicator 'eoh))) + (cond ((oref section hidden) + (unless ov + (setq ov (make-overlay (1- eoh) eoh)) + (overlay-put ov 'evaporate t) + (overlay-put ov 'magit-vis-indicator 'eoh)) + (overlay-put ov 'after-string + (car magit-section-visibility-indicator))) + (ov + (delete-overlay ov))))))))) + +(defvar-local magit--ellipses-sections nil) + +(defun magit-section-maybe-paint-visibility-ellipses () + ;; This is needed because we hide the body instead of "the body + ;; except the final newline and additionally the newline before + ;; the body"; otherwise we could use `buffer-invisibility-spec'. + (when (stringp (car-safe magit-section-visibility-indicator)) + (let* ((sections (append magit--ellipses-sections + (setq magit--ellipses-sections + (or (magit-region-sections) + (list (magit-current-section)))))) + (beg (mapcar (##oref % start) sections)) + (end (mapcar (##oref % end) sections))) + (when (region-active-p) + ;; This ensures that the region face is removed from ellipses + ;; when the region becomes inactive, but fails to ensure that + ;; all ellipses within the active region use the region face, + ;; because the respective overlay has not yet been updated at + ;; this time. The magit-selection face is always applied. + (push (region-beginning) beg) + (push (region-end) end)) + (setq beg (apply #'min beg)) + (setq end (apply #'max end)) + (dolist (ov (overlays-in beg end)) + (when (eq (overlay-get ov 'magit-vis-indicator) 'eoh) + (overlay-put + ov 'after-string + (propertize + (car magit-section-visibility-indicator) 'font-lock-face + (let ((pos (overlay-start ov))) + (delq nil (nconc (mapcar (##overlay-get % 'font-lock-face) + (overlays-at pos)) + (list (get-char-property + pos 'font-lock-face)))))))))))) + +(defun magit-section-maybe-remove-visibility-indicator (section) + (when (and magit-section-visibility-indicator + (= (oref section content) + (oref section end))) + (dolist (o (overlays-in (oref section start) + (1+ (magit--eol-position (oref section start))))) + (when (overlay-get o 'magit-vis-indicator) + (delete-overlay o))))) + +(defvar-local magit-section--opened-sections nil) + +(defun magit-section--open-temporarily (beg end) + (save-excursion + (goto-char beg) + (let ((section (magit-current-section))) + (while section + (let ((content (oref section content))) + (if (and (magit-section-invisible-p section) + (<= (or content (oref section start)) + beg + (oref section end))) + (progn + (when content + (magit-section-show section) + (push section magit-section--opened-sections)) + (setq section (oref section parent))) + (setq section nil)))))) + (or (eq search-invisible t) + (not (isearch-range-invisible beg end)))) + +(define-advice isearch-clean-overlays (:around (fn) magit-mode) + (if (derived-mode-p 'magit-mode) + (let ((pos (point))) + (dolist (section magit-section--opened-sections) + (unless (<= (oref section content) pos (oref section end)) + (magit-section-hide section))) + (setq magit-section--opened-sections nil)) + (funcall fn))) + +;;; Utilities + +(cl-defun magit-section-selected-p (section &optional (selection nil sselection)) + (and (not (eq section magit-root-section)) + (or (eq section (magit-current-section)) + (memq section (if sselection + selection + (setq selection (magit-region-sections)))) + (and-let* ((parent (oref section parent))) + (magit-section-selected-p parent selection))))) + +(defun magit-section-parent-value (section) + (and-let* ((parent (oref section parent))) + (oref parent value))) + +(defun magit-section-siblings (section &optional direction) + "Return a list of the sibling sections of SECTION. + +If optional DIRECTION is `prev', then return siblings that come +before SECTION. If it is `next', then return siblings that come +after SECTION. For all other values, return all siblings +excluding SECTION itself." + (and-let* ((parent (oref section parent)) + (siblings (oref parent children))) + (pcase direction + ('prev (cdr (member section (reverse siblings)))) + ('next (cdr (member section siblings))) + (_ (remq section siblings))))) + +(defun magit-focused-sections () + "Return a list of the selected sections and all their descendants. +If no sections are selected return a list of the current section and +its descendants, except if that is the root section, in which case +return nil." + (or magit-section-focused-sections + (setq magit-section-focused-sections + (let ((current (magit-current-section))) + (and (not (eq current magit-root-section)) + (let (sections) + (letrec ((collect (lambda (section) + (mapc collect (oref section children)) + (push section sections)))) + (mapc collect + (or (magit-region-sections) (list current)))) + sections)))))) + +(defun magit-region-values (&optional condition multiple) + "Return a list of the values of the selected sections. + +Return the values that themselves would be returned by +`magit-region-sections' (which see)." + (mapcar (##oref % value) + (magit-region-sections condition multiple))) + +(defun magit-region-sections (&optional condition multiple) + "Return a list of the selected sections. + +When the region is active and constitutes a valid section +selection, then return a list of all selected sections. This is +the case when the region begins in the heading of a section and +ends in the heading of the same section or in that of a sibling +section. If optional MULTIPLE is non-nil, then the region cannot +begin and end in the same section. + +When the selection is not valid, then return nil. In this case, +most commands that can act on the selected sections will instead +act on the section at point. + +When the region looks like it would in any other buffer then +the selection is invalid. When the selection is valid then the +region uses the `magit-section-highlight' face. This does not +apply to diffs where things get a bit more complicated, but even +here if the region looks like it usually does, then that's not +a valid selection as far as this function is concerned. + +If optional CONDITION is non-nil, then the selection not only +has to be valid; all selected sections additionally have to match +CONDITION, or nil is returned. See `magit-section-match' for the +forms CONDITION can take." + (and (region-active-p) + (let* ((rbeg (region-beginning)) + (rend (region-end)) + (sbeg (magit-section-at rbeg)) + (send (magit-section-at rend))) + ;; It should be possible to select a single section using + ;; `set-mark-command', so don't use `use-region-p' above. + ;; We still have to prevent the selection overlay from + ;; being flashed when clicking inside a section, which + ;; the first condition accomplishes: + (and (or (not (eq this-command #'mouse-drag-region)) + (> rend rbeg)) + send + (not (eq send magit-root-section)) + (not (and (eq send sbeg) + (or multiple + (> rend rbeg)))) + (let ((siblings (cons sbeg (magit-section-siblings sbeg 'next))) + (sections ())) + (and (memq send siblings) + (magit-section-position-in-heading-p sbeg rbeg) + (magit-section-position-in-heading-p send rend) + (progn + (while siblings + (push (car siblings) sections) + (when (eq (pop siblings) send) + (setq siblings nil))) + (setq sections (nreverse sections)) + (and (or (not condition) + (seq-every-p (##magit-section-match condition %) + sections)) + sections)))))))) + +(defun magit-map-sections (function &optional section) + "Apply FUNCTION to all sections for side effects only, depth first. +If optional SECTION is non-nil, only map over that section and +its descendants, otherwise map over all sections in the current +buffer, ending with `magit-root-section'." + (let ((section (or section magit-root-section))) + (mapc (##magit-map-sections function %) + (oref section children)) + (funcall function section))) + +(defun magit-section-position-in-heading-p (&optional section pos) + "Return t if POSITION is inside the heading of SECTION. +POSITION defaults to point and SECTION defaults to the +current section." + (unless section + (setq section (magit-current-section))) + (unless pos + (setq pos (point))) + (ignore-errors ; Allow navigating broken sections. + (and section + (>= pos (oref section start)) + (< pos (or (oref section content) + (oref section end))) + t))) + +(defun magit-section-internal-region-p (&optional section) + "Return t if the region is active and inside SECTION's body. +If optional SECTION is nil, use the current section." + (and (region-active-p) + (or section (setq section (magit-current-section))) + (let ((beg (magit-section-at (region-beginning)))) + (and (eq beg (magit-section-at (region-end))) + (eq beg section))) + (not (or (magit-section-position-in-heading-p section (region-beginning)) + (magit-section-position-in-heading-p section (region-end)))) + t)) + +(defun magit-wash-sequence (function) + "Repeatedly call FUNCTION until it returns nil or eob is reached. +FUNCTION has to move point forward or return nil." + (while (and (not (eobp)) (funcall function)))) + +;;;###autoload +(defun magit-add-section-hook (hook function &optional at append local) + "Add to the value of section hook HOOK the function FUNCTION. + +Add FUNCTION at the beginning of the hook list unless optional +APPEND is non-nil, in which case FUNCTION is added at the end. +If FUNCTION already is a member, then move it to the new location. + +If optional AT is non-nil and a member of the hook list, then +add FUNCTION next to that instead. Add before or after AT, or +replace AT with FUNCTION depending on APPEND. If APPEND is the +symbol `replace', then replace AT with FUNCTION. For any other +non-nil value place FUNCTION right after AT. If nil, then place +FUNCTION right before AT. If FUNCTION already is a member of the +list but AT is not, then leave FUNCTION where ever it already is. + +If optional LOCAL is non-nil, then modify the hook's buffer-local +value rather than its global value. This makes the hook local by +copying the default value. That copy is then modified. + +HOOK should be a symbol. If HOOK is void, it is first set to nil. +HOOK's value must not be a single hook function. FUNCTION should +be a function that takes no arguments and inserts one or multiple +sections at point, moving point forward. FUNCTION may choose not +to insert its section(s), when doing so would not make sense. It +should not be abused for other side-effects. To remove FUNCTION +again use `remove-hook'." + (unless (boundp hook) + (error "Cannot add function to undefined hook variable %s" hook)) + (unless (default-boundp hook) + (set-default hook nil)) + (let ((value (if local + (if (local-variable-p hook) + (symbol-value hook) + (unless (local-variable-if-set-p hook) + (make-local-variable hook)) + (copy-sequence (default-value hook))) + (default-value hook)))) + (if at + (when (setq at (member at value)) + (setq value (delq function value)) + (cond ((eq append 'replace) + (setcar at function)) + (append + (push function (cdr at))) + (t + (push (car at) (cdr at)) + (setcar at function)))) + (setq value (delq function value))) + (unless (member function value) + (setq value (if append + (append value (list function)) + (cons function value)))) + (when (eq append 'replace) + (setq value (delq at value))) + (if local + (set hook value) + (set-default hook value)))) + +(defvar-local magit-disabled-section-inserters nil) + +(defun magit-disable-section-inserter (fn) + "Disable the section inserter FN in the current repository. +It is only intended for use in \".dir-locals.el\" and +\".dir-locals-2.el\". Also see info node `(magit)Per-Repository +Configuration'." + (cl-pushnew fn magit-disabled-section-inserters)) + +(put 'magit-disable-section-inserter 'safe-local-eval-function t) + +(defun magit-run-section-hook (hook &rest args) + "Run HOOK with ARGS, warning about invalid entries." + (let ((entries (symbol-value hook))) + (unless (listp entries) + (setq entries (list entries))) + (when-let ((invalid (seq-remove #'functionp entries))) + (message "`%s' contains entries that are no longer valid. +%s\nUsing standard value instead. Please re-configure hook variable." + hook + (mapconcat (##format " `%s'" %) invalid "\n")) + (sit-for 5) + (setq entries (eval (car (get hook 'standard-value))))) + (dolist (entry entries) + (let ((magit--current-section-hook (cons (list hook entry) + magit--current-section-hook))) + (unless (memq entry magit-disabled-section-inserters) + (if (bound-and-true-p magit-refresh-verbose) + (let ((time (benchmark-elapse (apply entry args)))) + (message " %-50s %f %s" entry time + (cond ((> time 0.03) "!!") + ((> time 0.01) "!") + (t "")))) + (apply entry args))))))) + +(cl-defun magit--overlay-at (pos prop &optional (val nil sval) testfn) + (cl-find-if (lambda (o) + (let ((p (overlay-properties o))) + (and (plist-member p prop) + (or (not sval) + (funcall (or testfn #'eql) + (plist-get p prop) + val))))) + (overlays-at pos t))) + +(defun magit-face-property-all (face string) + "Return non-nil if FACE is present in all of STRING." + (catch 'missing + (let ((pos 0)) + (while (setq pos (next-single-property-change pos 'font-lock-face string)) + (let ((val (get-text-property pos 'font-lock-face string))) + (unless (if (consp val) + (memq face val) + (eq face val)) + (throw 'missing nil)))) + (not pos)))) + +(defun magit--add-face-text-property ( beg end face + &optional append object adopt-face) + "Like `add-face-text-property' but for `font-lock-face'. +If optional ADOPT-FACE, the replace `face' with `font-lock-face' +first. This is a hack, which is likely to be remove again." + (when (stringp object) + (unless beg (setq beg 0)) + (unless end (setq end (length object)))) + (when adopt-face + (let ((beg beg) + (end end)) + (while (< beg end) + (let ((pos (next-single-property-change beg 'face object end)) + (val (get-text-property beg 'face object))) + ;; We simply assume font-lock-face is not also set. + (put-text-property beg pos 'font-lock-face val object) + (remove-list-of-text-properties beg pos '(face) object) + (setq beg pos))))) + (while (< beg end) + (let* ((pos (next-single-property-change beg 'font-lock-face object end)) + (val (get-text-property beg 'font-lock-face object)) + (val (ensure-list val))) + (put-text-property beg pos 'font-lock-face + (if append + (append val (list face)) + (cons face val)) + object) + (setq beg pos))) + object) + +(defun magit--propertize-face (string face) + (propertize string 'face face 'font-lock-face face)) + +(defun magit--put-face (beg end face string) + (put-text-property beg end 'face face string) + (put-text-property beg end 'font-lock-face face string)) + +(defun magit--bolp (pos) + "Return t if POS is at the beginning of a line. +This is like moving to POS and then calling `bolp'." + (save-excursion (goto-char pos) (bolp))) + +(defun magit--eolp (pos) + "Return t if POS is at the end of a line. +This is like moving to POS and then calling `eolp'." + (save-excursion (goto-char pos) (bolp))) + +(defun magit--bol-position (pos) + "Return the position at the beginning of the line containing POS. +This is like moving to POS and then calling `pos-bol'." + (save-excursion (goto-char pos) (pos-bol))) + +(defun magit--eol-position (pos) + "Return the position at the end of the line containing POS. +This is like moving to POS and then calling `pos-eol'." + (save-excursion (goto-char pos) (pos-eol))) + +;;; Imenu Support + +(defvar-local magit--imenu-group-types nil) +(defvar-local magit--imenu-item-types nil) + +(defun magit--imenu-create-index () + ;; If `which-function-mode' is active, then the create-index + ;; function is called at the time the major-mode is being enabled. + ;; Modes that derive from `magit-mode' have not populated the buffer + ;; at that time yet, so we have to abort. + (and magit-root-section + (or magit--imenu-group-types + magit--imenu-item-types) + (let ((index + (mapcan + (lambda (section) + (cond + (magit--imenu-group-types + (and (if (eq (car-safe magit--imenu-group-types) 'not) + (not (magit-section-match + (cdr magit--imenu-group-types) + section)) + (magit-section-match magit--imenu-group-types section)) + (and-let* ((children (oref section children))) + `((,(magit--imenu-index-name section) + ,@(mapcar (##cons (magit--imenu-index-name %) + (oref % start)) + children)))))) + (magit--imenu-item-types + (and (magit-section-match magit--imenu-item-types section) + `((,(magit--imenu-index-name section) + . ,(oref section start))))))) + (oref magit-root-section children)))) + (if (and magit--imenu-group-types (symbolp magit--imenu-group-types)) + (cdar index) + index)))) + +(defun magit--imenu-index-name (section) + (let ((heading (buffer-substring-no-properties + (oref section start) + (1- (or (oref section content) + (oref section end)))))) + (save-match-data + (cond + ((and (magit-section-match [commit logbuf] section) + (string-match "[^ ]+\\([ *|]*\\).+" heading)) + (replace-match " " t t heading 1)) + ((magit-section-match + '([branch local branchbuf] [tag tags branchbuf]) section) + (oref section value)) + ((magit-section-match [branch remote branchbuf] section) + (concat (oref (oref section parent) value) "/" + (oref section value))) + ((string-match " ([0-9]+)\\'" heading) + (substring heading 0 (match-beginning 0))) + (t heading))))) + +(defun magit--imenu-goto-function (_name position &rest _rest) + "Go to the section at POSITION. +Make sure it is visible, by showing its ancestors where +necessary. For use as `imenu-default-goto-function' in +`magit-mode' buffers." + (goto-char position) + (let ((section (magit-current-section))) + (while (setq section (oref section parent)) + (when (oref section hidden) + (magit-section-show section))))) + +;;; Bookmark support + +(declare-function bookmark-get-filename "bookmark" (bookmark-name-or-record)) +(declare-function bookmark-make-record-default "bookmark" + (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark-name-or-record prop)) +(declare-function bookmark-prop-set "bookmark" (bookmark-name-or-record prop val)) + +(cl-defgeneric magit-bookmark-get-filename () + (or (buffer-file-name) (buffer-name))) + +(cl-defgeneric magit-bookmark-get-value (bookmark mode)) + +(cl-defgeneric magit-bookmark--get-child-value (section) + (oref section value)) + +(cl-defgeneric magit-bookmark-get-buffer-create (bookmark mode)) + +(defun magit--make-bookmark () + "Create a bookmark for the current Magit buffer. +Input values are the major-mode's `magit-bookmark-name' method, +and the buffer-local values of the variables referenced in its +`magit-bookmark-variables' property." + (require 'bookmark) + (if (plist-member (symbol-plist major-mode) 'magit-bookmark-variables) + ;; `bookmark-make-record-default's return value does not match + ;; (NAME . ALIST), even though it is used as the default value + ;; of `bookmark-make-record-function', which states that such + ;; functions must do that. See #4356. + (let ((bookmark (cons nil (bookmark-make-record-default 'no-file)))) + (bookmark-prop-set bookmark 'handler #'magit--handle-bookmark) + (bookmark-prop-set bookmark 'mode major-mode) + (bookmark-prop-set bookmark 'filename (magit-bookmark-get-filename)) + (bookmark-prop-set bookmark 'defaults (list (magit-bookmark-name))) + (magit-bookmark-get-value bookmark) + (bookmark-prop-set + bookmark 'magit-hidden-sections + (seq-keep (##and (oref % hidden) + (cons (oref % type) + (magit-bookmark--get-child-value %))) + (oref magit-root-section children))) + bookmark) + (user-error "Bookmarking is not implemented for %s buffers" major-mode))) + +;;;###autoload +(defun magit--handle-bookmark (bookmark) + "Open a bookmark created by `magit--make-bookmark'. + +Call the generic function `magit-bookmark-get-buffer-create' to get +the appropriate buffer without displaying it. + +Then call the `magit-*-setup-buffer' function of the the major-mode +with the variables' values as arguments, which were recorded by +`magit--make-bookmark'." + (require (quote magit-bookmark) nil t) + (let ((buffer (magit-bookmark-get-buffer-create + bookmark + (bookmark-prop-get bookmark 'mode)))) + (set-buffer buffer) ; That is the interface we have to adhere to. + (when-let ((hidden (bookmark-prop-get bookmark 'magit-hidden-sections))) + (with-current-buffer buffer + (dolist (child (oref magit-root-section children)) + (if (member (cons (oref child type) + (oref child value)) + hidden) + (magit-section-hide child) + (magit-section-show child))))) + ;; Compatibility with `bookmark+' package. See #4356. + (when (bound-and-true-p bmkp-jump-display-function) + (funcall bmkp-jump-display-function (current-buffer))) + nil)) + +(put 'magit--handle-bookmark 'bookmark-handler-type "Magit") + +(cl-defgeneric magit-bookmark-name () + "Return name for bookmark to current buffer." + (format "%s%s" + (substring (symbol-name major-mode) 0 -5) + (if-let ((vars (get major-mode 'magit-bookmark-variables))) + (mapcan (##ensure-list (symbol-value %)) vars) + ""))) + +;;; Bitmaps + +(define-fringe-bitmap 'magit-fringe-bitmap+ + [#b00000000 + #b00011000 + #b00011000 + #b01111110 + #b01111110 + #b00011000 + #b00011000 + #b00000000]) + +(define-fringe-bitmap 'magit-fringe-bitmap- + [#b00000000 + #b00000000 + #b00000000 + #b01111110 + #b01111110 + #b00000000 + #b00000000 + #b00000000]) + +(define-fringe-bitmap 'magit-fringe-bitmap> + [#b01100000 + #b00110000 + #b00011000 + #b00001100 + #b00011000 + #b00110000 + #b01100000 + #b00000000]) + +(define-fringe-bitmap 'magit-fringe-bitmapv + [#b00000000 + #b10000010 + #b11000110 + #b01101100 + #b00111000 + #b00010000 + #b00000000 + #b00000000]) + +(define-fringe-bitmap 'magit-fringe-bitmap-bold> + [#b11100000 + #b01110000 + #b00111000 + #b00011100 + #b00011100 + #b00111000 + #b01110000 + #b11100000]) + +(define-fringe-bitmap 'magit-fringe-bitmap-boldv + [#b10000001 + #b11000011 + #b11100111 + #b01111110 + #b00111100 + #b00011000 + #b00000000 + #b00000000]) + +;;; _ +(provide 'magit-section) +;;; magit-section.el ends here blob - /dev/null blob + 68f633db17a10400f52696a966d9439c3b97b7e0 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8/magit-section.info @@ -0,0 +1,315 @@ +This is docbaGvrP.info, produced by makeinfo version 6.8 from +magit-section.texi. + + Copyright (C) 2015-2025 Jonas Bernoulli + + + You can redistribute this document and/or modify it under the terms + of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) + any later version. + + This document 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. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Magit-Section: (magit-section). Use Magit sections in your own packages. +END-INFO-DIR-ENTRY + + +File: docbaGvrP.info, Node: Top, Next: Introduction, Up: (dir) + +Magit-Section Developer Manual +****************************** + +This package implements the main user interface of Magit — the +collapsible sections that make up its buffers. This package used to be +distributed as part of Magit but how it can also be used by other +packages that have nothing to do with Magit or Git. + + To learn more about the section abstraction and available commands +and user options see *note (magit)Sections::. This manual documents how +you can use sections in your own packages. + +This manual is for Magit-Section version 4.3.8. + + Copyright (C) 2015-2025 Jonas Bernoulli + + + You can redistribute this document and/or modify it under the terms + of the GNU General Public License as published by the Free Software + Foundation, either version 3 of the License, or (at your option) + any later version. + + This document 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. + +* Menu: + +* Introduction:: +* Creating Sections:: +* Core Functions:: +* Matching Functions:: + + +File: docbaGvrP.info, Node: Introduction, Next: Creating Sections, Prev: Top, Up: Top + +1 Introduction +************** + +This package implements the main user interface of Magit — the +collapsible sections that make up its buffers. This package used to be +distributed as part of Magit but how it can also be used by other +packages that have nothing to do with Magit or Git. + + To learn more about the section abstraction and available commands +and user options see *note (magit)Sections::. This manual documents how +you can use sections in your own packages. + + When the documentation leaves something unaddressed, then please +consider that Magit uses this library extensively and search its source +for suitable examples before asking me for help. Thanks! + + +File: docbaGvrP.info, Node: Creating Sections, Next: Core Functions, Prev: Introduction, Up: Top + +2 Creating Sections +******************* + +Macro: magit-insert-section [name] (type &optional value hide) &rest body + Create a section object of type CLASS, storing VALUE in its ‘value’ + slot, and insert the section at point. CLASS is a subclass of + ‘magit-section’ or has the form ‘(eval FORM)’, in which case FORM + is evaluated at runtime and should return a subclass. In other + places a sections class is often referred to as its "type". + + Many commands behave differently depending on the class of the + current section and sections of a certain class can have their own + keymap, which is specified using the ‘keymap’ class slot. The + value of that slot should be a variable whose value is a keymap. + + For historic reasons Magit and Forge in most cases use symbols as + CLASS that don’t actually identify a class and that lack the + appropriate package prefix. This works due to some undocumented + kludges, which are not available to other packages. + + When optional HIDE is non-nil collapse the section body by default, + i.e., when first creating the section, but not when refreshing the + buffer. Else expand it by default. This can be overwritten using + ‘magit-section-set-visibility-hook’. When a section is recreated + during a refresh, then the visibility of predecessor is inherited + and HIDE is ignored (but the hook is still honored). + + BODY is any number of forms that actually insert the section’s + heading and body. Optional NAME, if specified, has to be a symbol, + which is then bound to the object of the section being inserted. + + Before BODY is evaluated the ‘start’ of the section object is set + to the value of ‘point’ and after BODY was evaluated its ‘end’ is + set to the new value of ‘point’; BODY is responsible for moving + ‘point’ forward. + + If it turns out inside BODY that the section is empty, then + ‘magit-cancel-section’ can be used to abort and remove all traces + of the partially inserted section. This can happen when creating a + section by washing Git’s output and Git didn’t actually output + anything this time around. + +Function: magit-insert-heading [child-count] &rest args + Insert the heading for the section currently being inserted. + + This function should only be used inside ‘magit-insert-section’. + + When called without any arguments, then just set the ‘content’ slot + of the object representing the section being inserted to a marker + at ‘point’. The section should only contain a single line when + this function is used like this. + + When called with arguments ARGS, which have to be strings, or nil, + then insert those strings at point. The section should not contain + any text before this happens and afterwards it should again only + contain a single line. If the ‘face’ property is set anywhere + inside any of these strings, then insert all of them unchanged. + Otherwise use the ‘magit-section-heading’ face for all inserted + text. + + The ‘content’ property of the section object is the end of the + heading (which lasts from ‘start’ to ‘content’) and the beginning + of the the body (which lasts from ‘content’ to ‘end’). If the + value of ‘content’ is nil, then the section has no heading and its + body cannot be collapsed. If a section does have a heading, then + its height must be exactly one line, including a trailing newline + character. This isn’t enforced, you are responsible for getting it + right. The only exception is that this function does insert a + newline character if necessary. + + If provided, optional CHILD-COUNT must evaluate to an integer or + boolean. If t, then the count is determined once the children have + been inserted, using ‘magit-insert-child-count’ (which see). For + historic reasons, if the heading ends with ":", the count is + substituted for that, at this time as well. If + ‘magit-section-show-child-count’ is nil, no counts are inserted + +Macro: magit-insert-section-body &rest body + Use BODY to insert the section body, once the section is expanded. + If the section is expanded when it is created, then this is like + ‘progn’. Otherwise BODY isn’t evaluated until the section is + explicitly expanded. + +Function: magit-cancel-section + Cancel inserting the section that is currently being inserted. + Remove all traces of that section. + +Function: magit-wash-sequence function + Repeatedly call FUNCTION until it returns ‘nil’ or the end of the + buffer is reached. FUNCTION has to move point forward or return + ‘nil’. + + +File: docbaGvrP.info, Node: Core Functions, Next: Matching Functions, Prev: Creating Sections, Up: Top + +3 Core Functions +**************** + +Function: magit-current-section + Return the section at point or where the context menu was invoked. + When using the context menu, return the section that the user + clicked on, provided the current buffer is the buffer in which the + click occurred. Otherwise return the section at point. + +Function magit-section-at &optional position + Return the section at POSITION, defaulting to point. Default to + point even when the context menu is used. + +Function: magit-section-ident section + Return an unique identifier for SECTION. The return value has the + form ‘((TYPE . VALUE)...)’. + +Function: magit-section-ident-value value + Return a constant representation of VALUE. + + VALUE is the value of a ‘magit-section’ object. If that is an + object itself, then that is not suitable to be used to identify the + section because two objects may represent the same thing but not be + equal. If possible a method should be added for such objects, + which returns a value that is equal. Otherwise the catch-all + method is used, which just returns the argument itself. + +Function: magit-get-section ident &optional root + Return the section identified by IDENT. IDENT has to be a list as + returned by ‘magit-section-ident’. If optional ROOT is non-nil, + then search in that section tree instead of in the one whose root + ‘magit-root-section’ is. + +Function: magit-section-lineage section &optional raw + Return the lineage of SECTION. If optional RAW is non-nil, return + a list of section objects, beginning with SECTION, otherwise return + a list of section types. + +Function: magit-section-content-p section + Return non-nil if SECTION has content or an unused washer function. + + The next two functions are replacements for the Emacs functions that +have the same name except for the ‘magit-’ prefix. Like +‘magit-current-section’ they do not act on point, the cursors position, +but on the position where the user clicked to invoke the context menu. + + If your package provides a context menu and some of its commands act +on the "thing at point", even if just as a default, then use the +prefixed functions to teach them to instead use the click location when +appropriate. + +Function magit-point + Return point or the position where the context menu was invoked. + When using the context menu, return the position the user clicked + on, provided the current buffer is the buffer in which the click + occurred. Otherwise return the same value as ‘point’. + +Function magit-thing-at-point thing &optional no-properties + Return the THING at point or where the context menu was invoked. + When using the context menu, return the thing the user clicked on, + provided the current buffer is the buffer in which the click + occurred. Otherwise return the same value as ‘thing-at-point’. + For the meaning of THING and NO-PROPERTIES see that function. + + +File: docbaGvrP.info, Node: Matching Functions, Prev: Core Functions, Up: Top + +4 Matching Functions +******************** + +Function: magit-section-match condition &optional (section (magit-current-section)) + Return t if SECTION matches CONDITION. + + SECTION defaults to the section at point. If SECTION is not + specified and there also is no section at point, then return nil. + + CONDITION can take the following forms: + + • ‘(CONDITION...)’ matches if any of the CONDITIONs matches. + • ‘[CLASS...]’ matches if the section’s class is the same as the + first CLASS or a subclass of that; the section’s parent class + matches the second CLASS; and so on. + + • ‘[* CLASS...]’ matches sections that match [CLASS...] and also + recursively all their child sections. + • ‘CLASS’ matches if the section’s class is the same as CLASS or + a subclass of that; regardless of the classes of the parent + sections. + + Each CLASS should be a class symbol, identifying a class that + derives from ‘magit-section’. For backward compatibility CLASS can + also be a "type symbol". A section matches such a symbol if the + value of its ‘type’ slot is ‘eq’. If a type symbol has an entry in + ‘magit--section-type-alist’, then a section also matches that type + if its class is a subclass of the class that corresponds to the + type as per that alist. + + Note that it is not necessary to specify the complete section + lineage as printed by ‘magit-describe-section-briefly’, unless of + course you want to be that precise. + +Function: magit-section-value-if condition &optional section + If the section at point matches CONDITION, then return its value. + + If optional SECTION is non-nil then test whether that matches + instead. If there is no section at point and SECTION is nil, then + return nil. If the section does not match, then return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + +Macro: magit-section-case &rest clauses + Choose among clauses on the type of the section at point. + + Each clause looks like ‘(CONDITION BODY...)’. The type of the + section is compared against each CONDITION; the BODY forms of the + first match are evaluated sequentially and the value of the last + form is returned. Inside BODY the symbol ‘it’ is bound to the + section at point. If no clause succeeds or if there is no section + at point, return nil. + + See ‘magit-section-match’ for the forms CONDITION can take. + Additionally a CONDITION of t is allowed in the final clause, and + matches if no other CONDITION match, even if there is no section at + point. + + + +Tag Table: +Node: Top804 +Node: Introduction2101 +Node: Creating Sections2867 +Node: Core Functions7766 +Node: Matching Functions10890 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: blob - /dev/null blob + 9adf80de90611870a66930531fd5200a5e9579c7 (mode 644) --- /dev/null +++ elpa/magit-section-4.3.8.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2025-07-05T11:05:06+0200 using EDDSA \ No newline at end of file blob - /dev/null blob + dd498a90610eedca11e01e79bb191f288ea475c7 (mode 644) --- /dev/null +++ elpa/nhexl-mode-1.5/nhexl-mode-autoloads.el @@ -0,0 +1,46 @@ +;;; nhexl-mode-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from nhexl-mode.el + +(autoload 'nhexl-mode "nhexl-mode" "\ +Minor mode to edit files via hex-dump format + +This is a minor mode. If called interactively, toggle the `Nhexl mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `nhexl-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "nhexl-mode" '("nhexl-")) + +;;; End of scraped data + +(provide 'nhexl-mode-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; nhexl-mode-autoloads.el ends here blob - /dev/null blob + c22d3194846713161238c1201045546b81d9880d (mode 644) --- /dev/null +++ elpa/nhexl-mode-1.5/nhexl-mode-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from nhexl-mode.el -*- no-byte-compile: t -*- +(define-package "nhexl-mode" "1.5" "Minor mode to edit files via hex-dump format" '((emacs "24.4") (cl-lib "0.5")) :commit "ec80692dec04e238f2ae3284cfd8f9d05ac1d2a3" :url "https://elpa.gnu.org/packages/nhexl-mode.html" :authors '(("Stefan Monnier" . "monnier@iro.umontreal.ca")) :maintainer '("Stefan Monnier" . "monnier@iro.umontreal.ca") :keywords '("data")) blob - /dev/null blob + e1fe6aaa76e5e0ad6c4d530dbb1cc119537cecce (mode 644) --- /dev/null +++ elpa/nhexl-mode-1.5/nhexl-mode.el @@ -0,0 +1,1128 @@ +;;; nhexl-mode.el --- Minor mode to edit files via hex-dump format -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2020 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: data +;; Version: 1.5 +;; Package-Requires: ((emacs "24.4") (cl-lib "0.5")) + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; This package implements NHexl mode, a minor mode for editing files +;; in hex dump format. The mode command is called `nhexl-mode'. +;; +;; This minor mode implements similar functionality to `hexl-mode', +;; but using a different implementation technique, which makes it +;; usable as a "plain" minor mode. It works on any buffer, and does +;; not mess with the undo log or with the major mode. +;; +;; It also comes with: +;; +;; - `nhexl-nibble-edit-mode': a "nibble editor" minor mode. +;; where the cursor pretends to advance by nibbles (4-bit) and the +;; self-insertion keys let you edit the hex digits directly. +;; +;; - `nhexl-overwrite-only-mode': a minor mode to try and avoid moving text. +;; In this minor mode, not only self-inserting keys overwrite existing +;; text, but commands like `yank' and `kill-region' as well. +;; +;; - it overrides C-u to use hexadecimal, so you can do C-u a 4 C-f +;; to advance by #xa4 characters. + +;; Even though the hex addresses and hex data displayed by this mode aren't +;; actually part of the buffer's text (contrary to hexl-mode, for example, +;; they're only added to the display), you can search them with Isearch, +;; according to nhexl-isearch-hex-addresses and nhexl-isearch-hex-bytes. + +;;;; Known bugs: +;; +;; - When the buffer is displayed in several windows, the "cursor" in the hex +;; area only reflects one of the window-points. Fixing this would be rather +;; painful: +;; - for every cursor, we need an extra overlay with the `window' +;; property with its own `before-string'. +;; - because that overlay won't *replace* the normal overlay (the one +;; without the `window' property), we will need to *remove* that +;; overlay (lest we get 2 before-strings) and replace it with N overlays +;; with a `window' property (for all N other windows that don't have +;; their cursor on this line). +;; FWIW, the original `hexl-mode' has the same kind of problem. + +;;;; Wishlist: + +;; - An equivalent to hexl-mode's `hexl-bits'. +;; - Always reload the file with find-file-literally instead +;; of editing the multibyte representation? + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'hexl) ;For faces. + +(defgroup nhexl nil + "Edit a file in a hex dump format." + :group 'data) + +(defcustom nhexl-line-width 16 + "Number of bytes per line." + :type '(choice (integer :tag "Fixed width") (const :tag "Adjust to window" t))) + +(defcustom nhexl-display-unprintables nil + "If non-nil, display non-printable chars using the customary codes. +If nil, use just `.' for those chars instead of things like `\\NNN' or `^C'." + :type 'boolean) + +(defcustom nhexl-obey-font-lock t + "If non-nil, faces will only be applied when font-lock is enabled. +Otherwise they are applied unconditionally." + :type 'boolean) + +(defcustom nhexl-silently-convert-to-unibyte nil + "If non-nil `nhexl-mode' won't ask before converting the buffer to unibyte." + :type 'boolean) + +(defcustom nhexl-isearch-hex-addresses t + "If non-nil, hex search terms will look for matching addresses." + :type 'boolean) + +(defcustom nhexl-isearch-hex-bytes t + "If non-nil, hex search terms will look for matching bytes." + :type 'boolean) + +(defcustom nhexl-isearch-hex-highlight t + "If non-nil, nhexl will highlight Isearch matches in the hex areas as well." + :type 'boolean) + +(defcustom nhexl-group-size (max 1 (/ hexl-bits 8)) + "Number of bytes in each group. +Groups are separated by spaces." + :type 'integer) + +(defcustom nhexl-separate-line nil + ;; FIXME: This var is not taken into account when auto-sizing the + ;; line-width! + "If non-nil, put the ascii area below the hex, on a separate line." + :type 'boolean) + +(defvar nhexl--display-table + (let ((dt (make-display-table))) + (unless nhexl-display-unprintables + (dotimes (i 128) + (when (> (char-width i) 1) + (setf (aref dt i) [?.]))) + (dotimes (i 128) + (setf (aref dt (unibyte-char-to-multibyte (+ i 128))) [?.]))) + ;; (aset dt ?\n [?␊]) + (aset dt ?\t [?␉]) + dt)) + +(defvar-local nhexl--saved-vars nil) + +;;;; Nibble editing minor mode + +;; FIXME: Region highlighting in this minor mode should highlight the hex area +;; rather than only the ascii area! +;; FIXME: Kill&yank in this minor mode should work on the hex representation +;; of the buffer's content (and should obey overwrite-mode)! + +(defvar nhexl-nibble-edit-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap self-insert-command] #'nhexl-nibble-self-insert) + (define-key map [remap right-char] #'nhexl-nibble-forward) + (define-key map [remap forward-char] #'nhexl-nibble-forward) + (define-key map [remap left-char] #'nhexl-nibble-backward) + (define-key map [remap backward-char] #'nhexl-nibble-backward) + map)) + +;; FIXME: Reuben Thomas pointed out that the user may not think of it as +;; "editing nibbles" but "editing the hex codes" instead. +;; Maybe we should rename `nhexl-nibble-edit-mode'? +(defalias 'nhexl-hex-edit-mode #'nhexl-nibble-edit-mode) +(define-minor-mode nhexl-nibble-edit-mode + "Minor mode to edit the hex nibbles in `nhexl-mode'." + :global nil + (if nhexl-nibble-edit-mode + (setq-local cursor-type 'hbar) + (kill-local-variable 'cursor-type)) + (nhexl--refresh-cursor)) + +(defvar-local nhexl--nibbles nil + "Nibble state of the various `point's. +List of elements of the form (WINDOW OFFSET POINT TICKS), +where WINDOW can be nil (for the `point' of the buffer itself); +OFFSET is the nibble-position within the byte at POINT (0 = leftmost); +and TICKS is the `buffer-chars-modified-tick' for which this was valid.") + +(defun nhexl--nibble (&optional pos) + (let ((cwin (if (eq (current-buffer) (window-buffer)) (selected-window))) + (data ())) + (dolist (n nhexl--nibbles) + (let ((nwin (car n))) + (cond + ((eq cwin nwin) (setq data n)) + ((eq (current-buffer) (window-buffer nwin)) nil) + (t (setq nhexl--nibbles (delq n nhexl--nibbles)))))) + (or (and (eq (or pos (point)) (nth 2 data)) + (eq (buffer-chars-modified-tick) (nth 3 data)) + (nth 1 data)) + (progn + (setq nhexl--nibbles (delq data nhexl--nibbles)) + 0)))) + +(defun nhexl--nibble-set (n) + (let* ((cwin (if (eq (current-buffer) (window-buffer)) (selected-window))) + (data (assq cwin nhexl--nibbles))) + (unless data + (push (setq data (list cwin)) nhexl--nibbles)) + (setcdr data (list n (point) (buffer-chars-modified-tick))))) + +(defsubst nhexl--line-width () + (if (integerp nhexl-line-width) nhexl-line-width 16)) + +(defun nhexl--nibble-max (&optional char) + (unless char (setq char (following-char))) + (if (< char 256) 1 + (let ((i 1)) + (setq char (/ char 256)) + (while (> char 0) + (setq char (/ char 16)) + (setq i (1+ i))) + i))) + +(defun nhexl-nibble-forward () + "Advance by one nibble." + (interactive) + (let ((nib (nhexl--nibble))) + (if (>= nib (nhexl--nibble-max)) + (forward-char 1) + (nhexl--nibble-set (1+ nib)) + (nhexl--refresh-cursor)))) + +(defun nhexl-nibble-backward () + "Advance by one nibble." + (interactive) + (let ((nib (nhexl--nibble))) + (if (> nib 0) + (progn + (nhexl--nibble-set (1- nib)) + (nhexl--refresh-cursor)) + (backward-char 1) + (nhexl--nibble-set (nhexl--nibble-max))))) + +(defun nhexl-nibble-self-insert () + "Overwrite current nibble with the hex character you type." + (interactive) + (let* ((max (nhexl--nibble-max)) + (nib (min max (nhexl--nibble))) + (char (if (and (not overwrite-mode) (= nib 0)) 0 (following-char))) + (hex (format "%02x" char)) + (nhex (concat (substring hex 0 nib) + (string last-command-event) + (substring hex (1+ nib)))) + (nchar (string-to-number nhex 16))) + (insert nchar) + (unless (or (eobp) + (and (not overwrite-mode) (= nib 0))) + (delete-char 1)) + (if (= max nib) nil + (backward-char 1) + (nhexl--nibble-set (1+ nib))))) + +;;;; No insertion/deletion minor mode + +;; FIXME: To make it work more generally, we should hook into +;; after-change-function, but we can't work directly from there because +;; it's called at too fine a grain (an overwrite is actually an +;; insertion+deletion and will run after-change-function, twice). + +(defvar nhexl-overwrite-clear-byte ?\000 + "Byte to use to replace deleted content.") + +(defvar nhexl-overwrite-only-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap yank] #'nhexl-overwrite-yank) + (define-key map [remap yank-pop] #'nhexl-overwrite-yank-pop) + (define-key map [remap kill-region] #'nhexl-overwrite-kill-region) + (define-key map [remap delete-char] #'nhexl-overwrite-delete-char) + (define-key map [remap backward-delete-char-untabify] + #'nhexl-overwrite-backward-delete-char) + (define-key map [remap backward-delete-char] + #'nhexl-overwrite-backward-delete-char) + map)) + +(defun nhexl-overwrite-backward-delete-char (&optional arg) + "Delete ARG chars backward by overwriting them. +Uses `nhexl-overwrite-clear-byte'." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (nhexl-overwrite-delete-char (- arg)) + (forward-char (- arg)) + (save-excursion + (insert-char nhexl-overwrite-clear-byte arg) + (delete-char arg)))) + +(defun nhexl-overwrite-delete-char (&optional arg) + "Delete ARG chars forward by overwriting them. +Uses `nhexl-overwrite-clear-byte'." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (nhexl-overwrite-backward-delete-char (- arg)) + (insert-char nhexl-overwrite-clear-byte arg) + (delete-char arg))) + +(defun nhexl-overwrite-kill-region (beg end &optional region) + "Kill the region, replacing it with `nhexl-overwrite-clear-byte'." + (interactive (list (mark) (point) 'region)) + (copy-region-as-kill beg end region) + (barf-if-buffer-read-only) + (pcase-dolist (`(,beg . ,end) + (if region (funcall region-extract-function 'bounds) + (list beg end))) + (goto-char beg) + (nhexl-overwrite-delete-char (- end beg)))) + +(defun nhexl-overwrite--yank-wrapper (fun) + ;; FIXME? doesn't work when yanking things like rectangles. + (let ((orig-size (buffer-size))) + (funcall fun) + (let* ((inserted (- (buffer-size) orig-size)) + (deleted (delete-and-extract-region + (point) + (min (point-max) (+ (point) inserted))))) + (unless yank-undo-function + (setq yank-undo-function #'delete-region)) + (add-function :before yank-undo-function + (lambda (_beg end) + (save-excursion + (goto-char end) + (insert deleted))))))) + +(defun nhexl-overwrite-yank (&optional arg) + "Like `yank' but overwriting existing text." + (interactive "*P") + (nhexl-overwrite--yank-wrapper (lambda () (yank arg)))) + +(defun nhexl-overwrite-yank-pop (&optional arg) + "Like `yank-pop' but overwriting existing text." + (interactive "*P") + (nhexl-overwrite--yank-wrapper (lambda () (yank-pop arg)))) + +(defvar-local nhexl--overwrite-save-settings nil) + +(define-minor-mode nhexl-overwrite-only-mode + "Minor mode where text is only overwritten. +Insertion/deletion is avoided where possible and replaced by overwriting +existing text, if needed with `nhexl-overwrite-clear-byte'." + :lighter nil + (cond + (nhexl-overwrite-only-mode + (push (cons 'overwrite-mode overwrite-mode) + nhexl--overwrite-save-settings) + (setq-local overwrite-mode 'overwrite-mode-binary) + (setq-local overwrite-mode-binary " OnlyOvwrt")) + (t + (pcase-dolist (`(,var . ,val) + (prog1 nhexl--overwrite-save-settings + (setq nhexl--overwrite-save-settings nil))) + (set var val)) + (kill-local-variable 'overwrite-mode-binary)))) + +;;;; Main minor mode + +(defvar nhexl-mode-map + (let ((map (make-sparse-keymap))) + ;; `next-line' and `previous-line' work correctly, but they take ages in + ;; large buffers and allocate an insane amount of memory, so the GC is + ;; constantly triggered. + ;; So instead we just override them with our own custom-tailored functions + ;; which don't have to work nearly as hard to figure out where's the + ;; next line. + ;; FIXME: It would also be good to try and improve `next-line' and + ;; `previous-line' for this case, tho it is pretty pathological for them. + (define-key map [remap next-line] #'nhexl-next-line) + (define-key map [remap previous-line] #'nhexl-previous-line) + (define-key map [remap move-end-of-line] #'nhexl-move-end-of-line) + (define-key map [remap move-beginning-of-line] + #'nhexl-move-beginning-of-line) + ;; Just as for line movement, scrolling movement could/should work as-is + ;; but benefit from an ad-hoc implementation. + (define-key map [remap scroll-up-command] #'nhexl-scroll-up) + (define-key map [remap scroll-down-command] #'nhexl-scroll-down) + (define-key map [remap mouse-set-point] #'nhexl-mouse-set-point) + (define-key map [remap mouse-drag-region] #'nhexl-mouse-drag-region) + (define-key map [remap mouse-set-region] #'nhexl-mouse-set-region) + ;; FIXME: Should we really make it hard to use non-binary `overwrite-mode'? + ;; Or should we go even further and remap it to + ;; `nhexl-overwrite-only-mode'? + (define-key map [remap overwrite-mode] #'binary-overwrite-mode) + ;; FIXME: Find a key binding for nhexl-nibble-edit-mode! + map)) + +(defvar-local nhexl--point nil) + +;;;###autoload +(define-minor-mode nhexl-mode + "Minor mode to edit files via hex-dump format" + :lighter (" NHexl" (nhexl-nibble-edit-mode "/ne")) + (dolist (varl (prog1 nhexl--saved-vars + (kill-local-variable 'nhexl--saved-vars))) + (set (make-local-variable (car varl)) (cdr varl))) + + (if (not nhexl-mode) + (progn + (jit-lock-unregister #'nhexl--jit) + (remove-hook 'after-change-functions #'nhexl--change-function 'local) + (remove-hook 'post-command-hook #'nhexl--post-command 'local) + (if (>= emacs-major-version 27) + (remove-hook 'window-size-change-functions #'nhexl--window-size-change t) + (remove-hook 'window-configuration-change-hook + #'nhexl--window-config-change t) + (remove-hook 'window-size-change-functions #'nhexl--window-size-change)) + (remove-function (local 'isearch-search-fun-function) + #'nhexl--isearch-search-fun) + ;; FIXME: This conflicts with any other use of `display'. + (with-silent-modifications + (put-text-property (point-min) (point-max) 'display nil)) + (remove-overlays (point-min) (point-max) 'nhexl t)) + + (when (and enable-multibyte-characters + ;; No point changing to unibyte in a pure-ASCII buffer. + (not (= (position-bytes (point-max)) (point-max))) + (not (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "[^[:ascii:]\200-\377]" nil t)))) + ;; We're in a multibyte buffer which only contains bytes, + ;; so we could advantageously convert it to unibyte. + (or nhexl-silently-convert-to-unibyte + (y-or-n-p "Make buffer unibyte? "))) + (set-buffer-multibyte nil)) + + (unless (local-variable-p 'nhexl--saved-vars) + (dolist (var '(buffer-display-table buffer-invisibility-spec + overwrite-mode header-line-format word-wrap)) + (push (cons var (symbol-value var)) nhexl--saved-vars))) + (setq nhexl--point (point)) + ;; Word-wrap doesn't make much sense together with nhexl-mode and + ;; the display-engine tends to suffer unduly if it's enabled. + (setq-local word-wrap nil) + (setq-local header-line-format '(:eval (nhexl--header-line))) + (binary-overwrite-mode 1) + (setq-local buffer-invisibility-spec ()) + (setq-local buffer-display-table nhexl--display-table) + (jit-lock-register #'nhexl--jit) + (add-hook 'change-major-mode-hook (lambda () (nhexl-mode -1)) nil 'local) + (add-hook 'post-command-hook #'nhexl--post-command nil 'local) + (add-hook 'after-change-functions #'nhexl--change-function nil 'local) + (if (>= emacs-major-version 27) + (add-hook 'window-size-change-functions #'nhexl--window-size-change nil t) + (add-hook 'window-configuration-change-hook + #'nhexl--window-config-change nil 'local) + (add-hook 'window-size-change-functions #'nhexl--window-size-change)) + (add-function :around (local 'isearch-search-fun-function) + #'nhexl--isearch-search-fun) + ;; FIXME: We should delay this to after running the minor-mode hook. + (when (and (eq t (default-value 'nhexl-line-width)) + (eq (current-buffer) (window-buffer))) + (nhexl--adjust-to-width)))) + +(defun nhexl-next-line (&optional arg) + "Move cursor vertically down ARG lines." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (nhexl-previous-line (- arg)) + (let ((nib (nhexl--nibble))) + (forward-char (* arg (nhexl--line-width))) + (nhexl--nibble-set nib)))) + +(defun nhexl-previous-line (&optional arg) + "Move cursor vertically up ARG lines." + (interactive "p") + (unless arg (setq arg 1)) + (if (< arg 0) + (nhexl-next-line (- arg)) + (let ((nib (nhexl--nibble))) + (backward-char (* arg (nhexl--line-width))) + (nhexl--nibble-set nib)))) + +(defun nhexl-move-beginning-of-line (&optional arg) + "Move to beginning of the hex line that lies ARG - 1 hex lines ahead." + (interactive "p") + (unless arg (setq arg 1)) + (nhexl-next-line (- arg 1)) + (backward-char (mod (- (point) 1) nhexl-line-width))) + +(defun nhexl-move-end-of-line (&optional arg) + "Move to end of the hex line that lies ARG - 1 hex lines ahead." + (interactive "p") + (unless arg (setq arg 1)) + (nhexl-next-line (- arg 1)) + (forward-char (- nhexl-line-width 1 (mod (- (point) 1) nhexl-line-width)))) + +(defun nhexl-scroll-down (&optional arg) + "Scroll text of selected window down ARG lines; or near full screen if no ARG." + (interactive "P") + (unless arg + ;; Magic extra 2 lines: 1 line to account for the header-line, and a second + ;; to account for the extra empty line that somehow ends up being there + ;; pretty much all the time right below the header-line :-( + (setq arg (max 1 (- (window-text-height) next-screen-context-lines 2)))) + (cond + ((< arg 0) (nhexl-scroll-up (- arg))) + ((eq arg '-) (nhexl-scroll-up nil)) + ((bobp) (scroll-down arg)) ; signal error + (t + (let* ((ws (window-start)) + (nws (- ws (* (nhexl--line-width) arg)))) + (if (eq ws (point-min)) + (if scroll-error-top-bottom + (nhexl-previous-line arg) + (scroll-down arg)) + (nhexl-previous-line arg) + (set-window-start nil (max (point-min) nws))))))) + +(defun nhexl-scroll-up (&optional arg) + "Scroll text of selected window up ARG lines; or near full screen if no ARG." + (interactive "P") + (unless arg + ;; Magic extra 2 lines: 1 line to account for the header-line, and a second + ;; to account for the extra empty line that somehow ends up being there + ;; pretty much all the time right below the header-line :-( + (setq arg (max 1 (- (window-text-height) next-screen-context-lines 2)))) + (cond + ((< arg 0) (nhexl-scroll-down (- arg))) + ((eq arg '-) (nhexl-scroll-down nil)) + ((eobp) (scroll-up arg)) ; signal error + (t + (let* ((ws (window-start)) + (nws (+ ws (* (nhexl--line-width) arg)))) + (if (pos-visible-in-window-p (point-max)) + (if scroll-error-top-bottom + (nhexl-next-line arg) + (scroll-up arg)) + (nhexl-next-line arg) + (set-window-start nil (min (point-max) nws))))))) + +;; If we put the LFs in the before-string, we get a spurious empty +;; line at the top of the window (bug#31276), so we put the LFs +;; via a `display' property by default, but it's a bit complicated. +(eval-and-compile + (defvar nhexl--put-LF-in-string nil)) + +(defun nhexl--posn-hexadjust (posn) + "Adjust POSN when clicking on the hex area. +Return the corresponding nibble, if applicable." + ;; When clicking in the hex area, (nth 1 posn) contains the first position + ;; covered by the before-string, and (nth 5 posn) as well. Improve this by + ;; setting nth-5 (the one used by `posn-point') to the closest buffer + ;; position corresponding to the hex on which we clicked. + (let* ((str-data (posn-string posn)) + (base-pos (nth 1 posn)) + (addr-offset (eval-when-compile + (+ (if nhexl--put-LF-in-string 1 0) + 9 ;for "
:" + 1)))) ;for the following (stretch)space + ;; (message "NMSP: strdata=%S" str-data) + (when (and (consp str-data) (stringp (car str-data)) (integerp base-pos) + (integerp (cdr str-data)) (> (cdr str-data) addr-offset)) + (let* ((hexchars (- (cdr str-data) addr-offset)) + ;; FIXME: Calculations here go wrong in the presence of + ;; chars with code > 255. + (hex-no-spaces (- hexchars (/ (1+ hexchars) 5))) + (bytes (min (/ hex-no-spaces 2) + ;; Bound, for clicks between the hex and ascii areas. + (1- (nhexl--line-width)))) + (newpos (min (+ base-pos bytes) (point-max)))) + (setf (nth 5 posn) newpos) + (let* ((nibble (- hex-no-spaces (* bytes 2)))) + (min nibble 1)))))) + +(defun nhexl-mouse-set-point (event) + "Move point to the position clicked on with the mouse." + (interactive "e") + (let* ((nibble (nhexl--posn-hexadjust (event-end event)))) + (call-interactively #'mouse-set-point) + (when (and nibble nhexl-nibble-edit-mode) + (nhexl--nibble-set nibble) + (nhexl--refresh-cursor)))) + +(defun nhexl-mouse-drag-region (event) + "Set the region to the text that the mouse is dragged over." + (interactive "e") + (nhexl--posn-hexadjust (event-start event)) + (call-interactively #'mouse-drag-region)) + +(defun nhexl-mouse-set-region (event) + "Set the region to the text dragged over, and copy to kill ring." + (interactive "e") + (nhexl--posn-hexadjust (event-start event)) + (nhexl--posn-hexadjust (event-end event)) + (call-interactively #'mouse-set-region)) + +(defun nhexl--change-function (beg end len) + ;; Round modifications up-to the hexl-line length since nhexl--jit will need + ;; to modify the overlay that covers that text. + (let* ((zero (save-restriction (widen) (point-min))) + (lw (nhexl--line-width)) + (from (max (point-min) + (+ zero (* (truncate (- beg zero) lw) lw)))) + (to (min (point-max) + (+ zero (* (ceiling (- end zero) lw) + lw))))) + (with-silent-modifications ;Don't store this change in buffer-undo-list! + (put-text-property from to 'fontified nil))) + ;; Also make sure the tail's addresses are refreshed when + ;; text is inserted/removed. + (when (/= len (- end beg)) + (with-silent-modifications ;Don't store this change in buffer-undo-list! + (put-text-property beg (point-max) 'fontified nil)))) + +(defun nhexl--flush () + (save-restriction + (widen) + (nhexl--change-function (point-min) (point-max) (buffer-size)))) + +(defvar nhexl--overlay-counter 1000) +(make-variable-buffer-local 'nhexl--overlay-counter) + +(defun nhexl--debug-count-ols () + (let ((i 0)) + (dolist (ol (overlays-in (point-min) (point-max))) + (when (overlay-get ol 'nhexl) (cl-incf i))) + i)) + +(defun nhexl--flush-overlays (buffer) + (with-current-buffer buffer + (kill-local-variable 'nhexl--overlay-counter) + ;; We've created many overlays in this buffer, which can slow + ;; down operations significantly. Let's flush them. + ;; An easy way to flush them is + ;; (remove-overlays min max 'nhexl t) + ;; (put-text-property min max 'fontified nil) + ;; but if the visible part of the buffer requires more than + ;; nhexl--overlay-counter overlays, then we'll inf-loop. + ;; So let's be more careful about removing overlays. + (let ((windows (get-buffer-window-list nil nil t)) + (lw (nhexl--line-width)) + (start (point-min)) + (zero (save-restriction (widen) (point-min))) + (debug-count (nhexl--debug-count-ols))) + (with-silent-modifications + (while (< start (point-max)) + (let ((end (point-max))) + (dolist (window windows) + (cond + ((< start (1- (window-start window))) + (setq end (min (1- (window-start window)) end))) + ((< start (1+ (window-end window))) + (setq start (1+ (window-end window)))))) + ;; Round to multiple of lw. + (setq start (+ zero (* (ceiling (- start zero) lw) lw))) + (setq end (+ zero (* (truncate (- end zero) lw) lw))) + (when (< start end) + (remove-overlays start end 'nhexl t) + (put-text-property start end 'fontified nil) + (setq start (+ end lw)))))) + (let ((debug-new-count (nhexl--debug-count-ols))) + (message "Flushed %d overlays, %d remaining" + (- debug-count debug-new-count) debug-new-count))))) + +(defun nhexl--make-line (from next zero &optional point) + (let* ((nextpos (min next (point-max))) + (lw (nhexl--line-width)) + (bufstr (buffer-substring from nextpos)) + (prop (if nhexl-obey-font-lock 'font-lock-face 'face)) + (i -1) + (s (concat + (if nhexl--put-LF-in-string (unless (eq zero from) "\n")) + (format (if (or (null point) + (< point from) + (>= point next)) + (propertize "%08x:" prop 'hexl-address-region) + ;; The `face' property overrides the `font-lock-face' + ;; property (instead of being combined), but we want the + ;; `highlight' face to be present regardless of + ;; font-lock-mode, so we can't use font-lock-face. + (propertize "%08x:" 'face + (if (or font-lock-mode + (not nhexl-obey-font-lock)) + '(highlight hexl-address-region default) + 'highlight))) + (- from zero)) + (eval-when-compile (propertize " " 'display '(space :align-to 12))) + (mapconcat (lambda (c) + (setq i (1+ i)) + ;; FIXME: In multibyte buffers, do something clever + ;; about non-ascii chars. + (let ((s (format "%02x" c)) + face) + (when (and isearch-mode + (memq (setq face (get-char-property + (+ i from) 'face)) + '(lazy-highlight isearch))) + (put-text-property 0 (length s) 'face + `(,face default) s)) + (when (and point (eq point (+ from i))) + (if nhexl-nibble-edit-mode + (let ((nib (min (nhexl--nibble point) + (1- (length s))))) + (put-text-property nib (1+ nib) + 'face '(highlight default) + s)) + (put-text-property 0 (length s) + 'face '(highlight default) + s))) + (if (not (zerop (mod (1+ i) nhexl-group-size))) + ;; FIXME: If this char and the next are both + ;; covered by isearch highlight, we should + ;; also highlight the space. + s (concat s " ")))) + bufstr + "") + (if (> next nextpos) + (make-string (+ (/ (1+ (- next nextpos)) nhexl-group-size) + (* (- next nextpos) 2)) + ?\s)) + (if nhexl-separate-line + (concat "\n" + (propertize " " 'display + `(space :align-to 12))) + (propertize " " 'display + `(space :align-to + ,(+ (* lw 2) ;digits + (/ lw nhexl-group-size) ;spaces + 12 3))))))) ;addr + borders + (font-lock-append-text-property 0 (length s) prop 'default s) + ;; If the first char of the text has a button (e.g. it's part of + ;; a hyperlink), clicking in the hex part of the display might signal + ;; an error because it thinks we're clicking on the hyperlink. + ;; So override the relevant properties. + (put-text-property 0 (length s) 'keymap (make-sparse-keymap) s) + (put-text-property 0 (length s) 'follow-link #'ignore s) + ;; Override any `category' property that might otherwise be inherited from + ;; the text (e.g. that of some button). + ;; FIXME: This doesn't have the intended effect! + (put-text-property 0 (length s) 'category t s) + s)) + +(defun nhexl--jit (from to) + (let ((zero (save-restriction (widen) (point-min))) + (lw (nhexl--line-width))) + (setq from (max (point-min) + (+ zero (* (truncate (- from zero) lw) lw)))) + (setq to (min (point-max) + (+ zero (* (ceiling (- to zero) lw) lw)))) + (remove-overlays from to 'nhexl t) + (remove-text-properties from to '(display)) + (save-excursion + (goto-char from) + (while (search-forward "\n" to t) + (put-text-property (match-beginning 0) (match-end 0) + 'display (copy-sequence "␊")))) + (while (< from to) + + (cl-decf nhexl--overlay-counter) + (when (and (= nhexl--overlay-counter 0) + ;; If the user enabled jit-lock-stealth fontification, then + ;; removing overlays is just a waste since + ;; jit-lock-stealth will restore them anyway. + (not jit-lock-stealth-time)) + ;; (run-with-idle-timer 0 nil #'nhexl--flush-overlays (current-buffer)) + ) + + (let* ((next (+ from lw)) + (ol (make-overlay from next)) + (s (nhexl--make-line from next zero nhexl--point)) + (c (char-before next))) + (when nhexl-separate-line + (dotimes (i (- (min (point-max) next) from 1)) + (let ((ol (make-overlay (+ from i) (+ from i 1)))) + (overlay-put ol 'nhexl t) + (overlay-put ol 'after-string + (propertize " " 'display + `(space :align-to + ,(+ (* (1+ i) 2) ;digits + (/ (1+ i) nhexl-group-size) ;spaces + 12))))))) + (unless (or nhexl--put-LF-in-string (>= next (point-max))) + ;; Display tables aren't applied to strings in `display' properties, + ;; so we have to mimick it by hand. + (let ((cdisplay (aref nhexl--display-table + (if enable-multibyte-characters c + (unibyte-char-to-multibyte c))))) + (put-text-property (1- next) next + 'display (concat + (string (cond + ((eq c ?\n) ?␊) + (cdisplay (aref cdisplay 0)) + (t c))) + ;; Explicit set a `default' face + ;; lest it gets nhexl-ascii-region. + (eval-when-compile + (propertize "\n" 'face 'default)))))) + (overlay-put ol 'nhexl t) + (overlay-put ol (if nhexl-obey-font-lock 'font-lock-face 'face) + 'hexl-ascii-region) + ;; Make sure these overlays have less priority than that of (say) + ;; the region highlighting (since they're rather small). Another way + ;; to do it would be to add an overlay over the whole buffer with the + ;; `face' property. + (overlay-put ol 'priority most-negative-fixnum) + (overlay-put ol 'before-string s) + ;; (overlay-put ol 'after-string "\n") + (setq from next))) + )) + +(defun nhexl--refresh-cursor (&optional pos) + (unless pos (setq pos (point))) + (let* ((zero (save-restriction (widen) (point-min))) + (lw (nhexl--line-width)) + (n (truncate (- pos zero) lw)) + (from (max (point-min) (+ zero (* n lw)))) + (to (min (point-max) (+ zero (* (1+ n) lw))))) + (with-silent-modifications + (put-text-property from to 'fontified nil)))) + +(defun nhexl--header-line () + ;; FIXME: merge with nhexl--make-line? + ;; FIXME: Memoize last line to avoid recomputation! + (let* ((zero (save-restriction (widen) (point-min))) + (lw (nhexl--line-width)) + (text + (let ((tmp ())) + (dotimes (i lw) + (setq i (logand i #xf)) + (push (if (< i 10) (+ i ?0) (+ i -10 ?a)) tmp)) + (apply #'string (nreverse tmp)))) + (pos (1+ (mod (- (point) zero) lw))) + (i 0)) + (put-text-property (1- pos) pos 'face 'highlight text) + (concat + (eval-when-compile (propertize " " 'display '(space :align-to 0))) + "Address:" + (eval-when-compile (propertize " " 'display '(space :align-to 12))) + (mapconcat (lambda (c) + (setq i (1+ i)) + (let ((s (string c c))) + (when (eql i pos) + (if nhexl-nibble-edit-mode + (let ((nib (min (nhexl--nibble (point)) + (1- (length s))))) + (put-text-property nib (1+ nib) + 'face 'highlight + s)) + (put-text-property 0 (length s) + 'face 'highlight + s))) + (if (not (zerop (mod i nhexl-group-size))) + s + (concat + s (propertize " " 'display + `(space :align-to + ,(+ (* i 2) ;digits + (/ i nhexl-group-size) ;spaces + 12))))))) ;addr + text + "") + (unless nhexl-separate-line + (concat + (propertize " " 'display + `(space :align-to + ,(+ (* lw 2) ;digits + (/ lw nhexl-group-size) ;spaces + 12 3))) ;addr + border + text))))) + + +(defun nhexl--post-command () + (when (/= (point) nhexl--point) + (let ((zero (save-restriction (widen) (point-min))) + (lw (nhexl--line-width)) + (oldpoint nhexl--point)) + (setq nhexl--point (point)) + (nhexl--refresh-cursor) + ;; (nhexl--jit (point) (1+ (point))) + (if (/= (truncate (- (point) zero) lw) + (truncate (- oldpoint zero) lw)) + (nhexl--refresh-cursor oldpoint))))) + +(defun nhexl--isearch-match-hex-bytes (string bound noerror) + ;; "57a" can be taken as "57a." or ".57a", but we currently + ;; only handle "57a." + ;; TODO: Maybe we could support hex regexps as well? + (let ((i 0) + (chars ())) + (while (< (1+ i) (length string)) + (push (string-to-number (substring string i (+ i 2)) 16) + chars) + (setq i (+ i 2))) + (let* ((base (regexp-quote (apply #'unibyte-string (nreverse chars)))) + (re + (concat (if (>= i (length string)) + base + (cl-assert (= (1+ i) (length string))) + (let ((nibble (string-to-number (substring string i) 16))) + ;; FIXME: if one of the two bounds is a special char + ;; like `]` or `^' we can get into trouble! + (concat base + (unibyte-string ?\[ (* 16 nibble) ?- + (+ 15 (* 16 nibble)) ?\])))) + ;; We also search for the literal hex string here, so the + ;; search stops as soon as one is found, otherwise we too + ;; easily fall into the trap of bug#33708 where at every + ;; cycle we first search unsuccessfully through the whole + ;; buffer with one kind of search before trying the + ;; other search. + ;; Don't bother regexp-quoting the string since we know + ;; it's only made of hex chars! + "\\|" string))) + (let ((case-fold-search nil)) + (funcall (if isearch-forward + #'re-search-forward + #'re-search-backward) + re bound noerror))))) + +(defun nhexl--isearch-search-fun (orig-fun) + (let ((def-fun (funcall orig-fun))) + (lambda (string bound noerror) + (unless bound + (setq bound (if isearch-forward (point-max) (point-min)))) + ;; The order we used for the different searches is important: + ;; - First we do the hex-address search since it's always fast even in + ;; very large buffers. + ;; - Then we do the hex-bytes search. + ;; - Only last we fallback to the def-fun: if the user wants to + ;; do an hex-bytes search, the def-fun will likely fail but not + ;; without first scanning the whole buffer which can take a while, + ;; as in bug#33708. + (let ((startpos (point)) + def) + ;; Hex address search. + (when (and nhexl-isearch-hex-addresses + (> (length string) 1) + (string-match-p "\\`[[:xdigit:]]+:?\\'" string)) + ;; Could be a hexadecimal address. + (goto-char startpos) + (let ((newdef (nhexl--isearch-match-hex-address string bound noerror))) + (when newdef + (setq def newdef) + (setq bound (match-beginning 0))))) + ;; Hex bytes search + (when (and nhexl-isearch-hex-bytes + (> (length string) 1) + (string-match-p "\\`[[:xdigit:]]+\\'" string)) + ;; Could be a search pattern specified in hex. + (goto-char startpos) + (let ((newdef (nhexl--isearch-match-hex-bytes string bound noerror))) + (when newdef + (setq def newdef) + (setq bound (match-beginning 0))))) + ;; Normal search. + (progn + (goto-char startpos) + (let ((newdef (funcall def-fun string bound noerror))) + (when newdef + (setq def newdef) + (setq bound (match-beginning 0))))) + (when def + (goto-char def) + def))))) + +(defun nhexl--isearch-match-hex-address (string bound _noerror) + ;; FIXME: The code below works well to find the address, but the + ;; resulting isearch-highlighting is wrong (the char(s) at that position + ;; is highlighted, instead of the actual address matched in the + ;; before-string). + (let* ((addr (string-to-number string 16)) + ;; If `string' says "7a:", then it's "anchored", meaning that + ;; we'll only look for nearest address of the form "XXX7a" + ;; whereas if `string' says just "7a", then we look for nearest + ;; address of the form "XXX7a", or "XXX7aX", or "XXX7aXX", ... + (anchored (eq ?: (aref string (1- (length string))))) + (mod (lsh 1 (* 4 (- (length string) (if anchored 1 0))))) + (base (save-restriction (widen) (point-min))) + (bestnext nil) + (maxaddr (- (max (point) bound) base))) + (while (< addr maxaddr) + (let ((next (+ addr base (* (/ (- (point) base) mod) mod)))) + (if isearch-forward + (progn + (when (<= next (point)) + (setq next (+ next mod))) + (cl-assert (> next (point))) + (and (< next bound) + (or (null bestnext) (< next bestnext)) + (setq bestnext next))) + (when (>= next (point)) + (setq next (- next mod))) + (cl-assert (< next (point))) + (and (> next bound) + (or (null bestnext) (> next bestnext)) + (setq bestnext next)))) + (let ((nextmod (* mod 16))) + (if (or anchored + ;; Overflow! let's get out of the loop right away. + (< nextmod mod)) + (setq maxaddr -1) + (setq addr (* addr 16)) + (setq mod nextmod)))) + (when bestnext + (let* ((lw (nhexl--line-width)) + (me (+ (* lw (/ (- bestnext (point-min)) lw)) + (point-min) lw))) + (set-match-data (list bestnext me)) + (if isearch-forward + ;; Go to just before the last char on the line, + ;; otherwise, the cursor ends up on the + ;; next line! + (1- me) + bestnext))))) + +(advice-add 'lazy-highlight-cleanup :before + #'nhexl--isearch-highlight-cleanup) +(defun nhexl--isearch-highlight-cleanup (&rest _) + (when (and nhexl-mode nhexl-isearch-hex-highlight) + (with-silent-modifications + (dolist (ol isearch-lazy-highlight-overlays) + (when (and (overlayp ol) (eq (overlay-buffer ol) (current-buffer))) + (put-text-property (overlay-start ol) (overlay-end ol) + 'fontified nil)))))) + +(advice-add 'isearch-lazy-highlight-match :after + #'nhexl--isearch-highlight-match) +(defun nhexl--isearch-highlight-match (&optional mb me) + (when (and nhexl-mode nhexl-isearch-hex-highlight + (integerp mb) (integerp me)) + (with-silent-modifications + (put-text-property mb me 'fontified nil)))) + +(defun nhexl--line-width-watcher (_sym _newval op where) + (when (eq op 'set) + (dolist (buf (if where (list where) (buffer-list))) + (with-current-buffer buf + (when nhexl-mode (nhexl--flush)))))) + +(when (fboundp 'add-variable-watcher) + (add-variable-watcher 'nhexl-line-width #'nhexl--line-width-watcher)) + +(defun nhexl--window-size-change (frame-or-window) + (when (eq t (default-value 'nhexl-line-width)) + (if (windowp frame-or-window) ;Emacs≥27 + (with-selected-window frame-or-window + (nhexl--adjust-to-width)) + (dolist (win (window-list frame-or-window 'nomini)) + (when (buffer-local-value 'nhexl-mode (window-buffer win)) + (with-selected-window win (nhexl--adjust-to-width))))))) + +(defun nhexl--window-config-change () + ;; Doing it only from `window-size-change-functions' is not sufficient + ;; because it's not run when you set-window-buffer. + (when (eq t (default-value 'nhexl-line-width)) + (nhexl--adjust-to-width))) + +(defun nhexl--adjust-to-width () + ;; FIXME: What should we do with buffers displayed in several windows of + ;; different width? + (let ((win (get-buffer-window))) + (when win + (let* ((width (window-text-width win)) + (bytes (/ (- width + (eval-when-compile + (+ 9 ;Address + 3 ;Spaces between address and hex area + 4))) ;Spaces between hex area and ascii area + (+ 3 (/ 1.0 nhexl-group-size)))) ;Columns per byte + (pow2bytes (lsh 1 (truncate (log bytes 2))))) + (when (> (/ bytes pow2bytes) 1.5) + ;; Add 1½ steps: 4, *6*, 8, *12*, 16, *24*, 32, *48*, 64 + (setq pow2bytes (+ pow2bytes (/ pow2bytes 2)))) + (unless (eql pow2bytes nhexl-line-width) + (setq-local nhexl-line-width pow2bytes)))))) + +;;;;; The main prefix command. + +(defvar nhexl-universal-argument-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map universal-argument-map) + (define-key map [?\C-u] 'universal-argument-more) + (define-key map [remap digit-argument] 'nhexl-digit-argument) + (dolist (k '("a" "b" "c" "d" "e" "f")) + (define-key map k 'nhexl-digit-argument)) + map) + "Keymap used while processing nhexl-mode's \\[universal-argument].") + +;; FIXME: Using advice is ugly! + +;; Instead of an advice, we'd prefer to replace universal-argument--description +;; on prefix-command-echo-keystrokes-functions, but there's no mechanism to +;; do that. +(advice-add 'universal-argument--description :around + #'nhexl--universal-argument-description) +(defun nhexl--universal-argument-description (orig-fun &rest args) + (cond + ((not nhexl-mode) (apply orig-fun args)) + ((null prefix-arg) nil) + (t + (concat "C-u" + (pcase prefix-arg + (`(-) " -") + (`(,(and (pred integerp) n)) + (let ((str "")) + (while (and (> n 4) (= (mod n 4) 0)) + (setq str (concat str " C-u")) + (setq n (/ n 4))) + (if (= n 4) str (format " %s" prefix-arg)))) + ((pred integerp) (format " #x%X" prefix-arg)) + (_ (format " %s" prefix-arg))))))) + +(advice-add 'universal-argument--mode :around + #'nhexl--universal-argument-mode) +(defun nhexl--universal-argument-mode (orig-fun &rest args) + (if (not nhexl-mode) + (apply orig-fun args) + (let ((universal-argument-map nhexl-universal-argument-map)) + (apply orig-fun args)))) + +(defun nhexl-digit-argument (arg) + "Part of the hexadecimal numeric argument for the next command. +\\[universal-argument] following digits or minus sign ends the argument." + (interactive "P") + (prefix-command-preserve-state) + (let* ((keys (this-command-keys)) + (key (aref keys (1- (length keys)))) + (char (if (integerp key) (logand key #x7f))) + (digit (cond + ((<= ?a char ?f) (+ 10 (- char ?a))) + ((<= ?A char ?F) (+ 10 (- char ?A))) + ((<= ?0 char ?9) (- char ?0))))) + (setq prefix-arg (cond ((integerp arg) + (+ (* arg 16) + (if (< arg 0) (- digit) digit))) + ((eq arg '-) + ;; Treat -0 as just -, so that -01 will work. + (if (zerop digit) '- (- digit))) + (t + digit)))) + (universal-argument--mode)) + + +(provide 'nhexl-mode) +;;; nhexl-mode.el ends here blob - /dev/null blob + afa08ddc221d893dbefcd35e793a8720c34e40ae (mode 644) --- /dev/null +++ elpa/nhexl-mode-1.5.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2024-03-31T11:40:08+0200 using EDDSA \ No newline at end of file blob - /dev/null blob + 79d2a1b7f03db509b95705b1701fa601cf7987ca (mode 644) --- /dev/null +++ elpa/notmuch-0.39/coolj.el @@ -0,0 +1,145 @@ +;;; coolj.el --- automatically wrap long lines -*- lexical-binding: t; coding: utf-8 -*- + +;; Copyright (C) 2000, 2001, 2004-2009 Free Software Foundation, Inc. + +;; Authors: Kai Grossjohann +;; Alex Schroeder +;; Chong Yidong +;; Maintainer: David Edmondson +;; Keywords: convenience, wp + +;; This file is not 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 3 of the License, 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. If not, see . + +;;; Commentary: + +;; This is a simple derivative of some functionality from +;; `longlines.el'. The key difference is that this version will +;; insert a prefix at the head of each wrapped line. The prefix is +;; calculated from the originating long line. + +;; No minor-mode is provided, the caller is expected to call +;; `coolj-wrap-region' to wrap the region of interest. + +;;; Code: + +(defgroup coolj nil + "Wrapping of long lines with prefix." + :group 'fill) + +(defcustom coolj-wrap-follows-window-size t + "Non-nil means wrap text to the window size. +Otherwise respect `fill-column'." + :group 'coolj + :type 'boolean) + +(defcustom coolj-line-prefix-regexp "^\\(>+ ?\\)*" + "Regular expression that matches line prefixes." + :group 'coolj + :type 'regexp) + +(defvar-local coolj-wrap-point nil) + +(defun coolj-determine-prefix () + "Determine the prefix for the current line." + (save-excursion + (beginning-of-line) + (if (re-search-forward coolj-line-prefix-regexp nil t) + (buffer-substring (match-beginning 0) (match-end 0)) + ""))) + +(defun coolj-wrap-buffer () + "Wrap the current buffer." + (coolj-wrap-region (point-min) (point-max))) + +(defun coolj-wrap-region (beg end) + "Wrap each successive line, starting with the line before BEG. +Stop when we reach lines after END that don't need wrapping, or the +end of the buffer." + (setq fill-column (if coolj-wrap-follows-window-size + (window-width) + fill-column)) + (let ((mod (buffer-modified-p))) + (setq coolj-wrap-point (point)) + (goto-char beg) + (forward-line -1) + ;; Two successful coolj-wrap-line's in a row mean successive + ;; lines don't need wrapping. + (while (null (and (coolj-wrap-line) + (or (eobp) + (and (>= (point) end) + (coolj-wrap-line)))))) + (goto-char coolj-wrap-point) + (set-buffer-modified-p mod))) + +(defun coolj-wrap-line () + "If the current line needs to be wrapped, wrap it and return nil. +If wrapping is performed, point remains on the line. If the line does +not need to be wrapped, move point to the next line and return t." + (let ((prefix (coolj-determine-prefix))) + (if (coolj-set-breakpoint prefix) + (progn + (insert-before-markers ?\n) + (backward-char 1) + (delete-char -1) + (forward-char 1) + (insert-before-markers prefix) + nil) + (forward-line 1) + t))) + +(defun coolj-set-breakpoint (prefix) + "Place point where we should break the current line, and return t. +If the line should not be broken, return nil; point remains on the +line." + (move-to-column fill-column) + (and (re-search-forward "[^ ]" (line-end-position) 1) + (> (current-column) fill-column) + ;; This line is too long. Can we break it? + (or (coolj-find-break-backward prefix) + (progn (move-to-column fill-column) + (coolj-find-break-forward))))) + +(defun coolj-find-break-backward (prefix) + "Move point backward to the first available breakpoint and return t. +If no breakpoint is found, return nil." + (let ((end-of-prefix (+ (line-beginning-position) (length prefix)))) + (and (search-backward " " end-of-prefix 1) + (save-excursion + (skip-chars-backward " " end-of-prefix) + (null (bolp))) + (progn (forward-char 1) + (if (and fill-nobreak-predicate + (run-hook-with-args-until-success + 'fill-nobreak-predicate)) + (progn (skip-chars-backward " " end-of-prefix) + (coolj-find-break-backward prefix)) + t))))) + +(defun coolj-find-break-forward () + "Move point forward to the first available breakpoint and return t. +If no break point is found, return nil." + (and (search-forward " " (line-end-position) 1) + (progn (skip-chars-forward " " (line-end-position)) + (null (eolp))) + (if (and fill-nobreak-predicate + (run-hook-with-args-until-success + 'fill-nobreak-predicate)) + (coolj-find-break-forward) + t))) + +(provide 'coolj) + +;;; coolj.el ends here blob - /dev/null blob + 8c9e0a27e988abf1e1da9d1230ea702c856bcdf7 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/make-deps.el @@ -0,0 +1,69 @@ +;;; make-deps.el --- compute make dependencies for Elisp sources -*- lexical-binding: t -*- +;; +;; Copyright © Austin Clements +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Austin Clements + +;;; Code: + +(defun batch-make-deps () + "Invoke `make-deps' for each file on the command line." + (setq debug-on-error t) + (dolist (file command-line-args-left) + (let ((default-directory command-line-default-directory)) + (find-file-literally file)) + (make-deps command-line-default-directory)) + (kill-emacs)) + +(defun make-deps (&optional dir) + "Print make dependencies for the current buffer. + +This prints make dependencies to `standard-output' based on the +top-level `require' expressions in the current buffer. Paths in +rules will be given relative to DIR, or `default-directory'." + (unless dir + (setq dir default-directory)) + (save-excursion + (goto-char (point-min)) + (condition-case nil + (while t + (let ((form (read (current-buffer)))) + ;; Is it a (require 'x) form? + (when (and (listp form) (= (length form) 2) + (eq (car form) 'require) + (listp (cadr form)) (= (length (cadr form)) 2) + (eq (car (cadr form)) 'quote) + (symbolp (cadr (cadr form)))) + ;; Find the required library + (let* ((name (cadr (cadr form))) + (fname (locate-library (symbol-name name)))) + ;; Is this file and the library in the same directory? + ;; If not, assume it's a system library and don't + ;; bother depending on it. + (when (and fname + (string= (file-name-directory (buffer-file-name)) + (file-name-directory fname))) + ;; Print the dependency + (princ (format "%s.elc: %s.elc\n" + (file-name-sans-extension + (file-relative-name (buffer-file-name) dir)) + (file-name-sans-extension + (file-relative-name fname dir))))))))) + (end-of-file nil)))) + +;;; make-deps.el ends here blob - /dev/null blob + f756254cb8513ec062ca692299fbb39e4f683fe1 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-address.el @@ -0,0 +1,436 @@ +;;; notmuch-address.el --- address completion with notmuch -*- lexical-binding: t -*- +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Edmondson + +;;; Code: + +(require 'message) +(require 'notmuch-parser) +(require 'notmuch-lib) +(require 'notmuch-company) + +(declare-function company-manual-begin "company") + +;;; Cache internals + +(defvar notmuch-address-last-harvest 0 + "Time of last address harvest.") + +(defvar notmuch-address-completions (make-hash-table :test 'equal) + "Hash of email addresses for completion during email composition. +This variable is set by calling `notmuch-address-harvest'.") + +(defvar notmuch-address-full-harvest-finished nil + "Whether full completion address harvesting has finished. +Use `notmuch-address--harvest-ready' to access as that will load +a saved hash if necessary (and available).") + +(defun notmuch-address--harvest-ready () + "Return t if there is a full address hash available. + +If the hash is not present it attempts to load a saved hash." + (or notmuch-address-full-harvest-finished + (notmuch-address--load-address-hash))) + +;;; Options + +(defcustom notmuch-address-command 'internal + "Determines how address completion candidates are generated. + +If this is a string, then that string should be an external +program, which must take a single argument (searched string) +and output a list of completion candidates, one per line. + +If this is the symbol `internal', then an implementation is used +that relies on the \"notmuch address\" command, but does not use +any third-party (i.e. \"external\") programs. + +If this is the symbol `as-is', then Notmuch does not modify the +value of `message-completion-alist'. This option has to be set to +this value before `notmuch' is loaded, otherwise the modification +to `message-completion-alist' may already have taken place. This +setting obviously does not prevent `message-completion-alist' +from being modified at all; the user or some third-party package +may still modify it. + +Finally, if this is nil, then address completion is disabled." + :type '(radio + (const :tag "Use internal address completion" internal) + (string :tag "Use external completion command") + (const :tag "Disable address completion" nil) + (const :tag "Use default or third-party mechanism" as-is)) + :group 'notmuch-send + :group 'notmuch-address + :group 'notmuch-external) + +(defcustom notmuch-address-internal-completion '(sent nil) + "Determines how internal address completion generates candidates. + +This should be a list of the form (DIRECTION FILTER), where +DIRECTION is either sent or received and specifies whether the +candidates are searched in messages sent by the user or received +by the user (note received by is much faster), and FILTER is +either nil or a filter-string, such as \"date:1y..\" to append to +the query." + :type '(list :tag "Use internal address completion" + (radio + :tag "Base completion on messages you have" + :value sent + (const :tag "sent (more accurate)" sent) + (const :tag "received (faster)" received)) + (radio :tag "Filter messages used for completion" + (const :tag "Use all messages" nil) + (string :tag "Filter query"))) + ;; We override set so that we can clear the cache when this changes + :set (lambda (symbol value) + (set-default symbol value) + (setq notmuch-address-last-harvest 0) + (setq notmuch-address-completions (clrhash notmuch-address-completions)) + (setq notmuch-address-full-harvest-finished nil)) + :group 'notmuch-send + :group 'notmuch-address + :group 'notmuch-external) + +(defcustom notmuch-address-save-filename nil + "Filename to save the cached completion addresses. + +All the addresses notmuch uses for address completion will be +cached in this file. This has obvious privacy implications so +you should make sure it is not somewhere publicly readable." + :type '(choice (const :tag "Off" nil) + (file :tag "Filename")) + :group 'notmuch-send + :group 'notmuch-address + :group 'notmuch-external) + +(defcustom notmuch-address-selection-function 'notmuch-address-selection-function + "The function to select address from given list. + +The function is called with PROMPT, COLLECTION, and INITIAL-INPUT +as arguments (subset of what `completing-read' can be called +with). While executed the value of `completion-ignore-case' +is t. See documentation of function +`notmuch-address-selection-function' to know how address +selection is made by default." + :type 'function + :group 'notmuch-send + :group 'notmuch-address + :group 'notmuch-external) + +(defcustom notmuch-address-post-completion-functions nil + "Functions called after completing address. + +The completed address is passed as an argument to each function. +Note that this hook will be invoked for completion in headers +matching `notmuch-address-completion-headers-regexp'." + :type 'hook + :group 'notmuch-address + :group 'notmuch-hooks) + +(defcustom notmuch-address-use-company t + "If available, use company mode for address completion." + :type 'boolean + :group 'notmuch-send + :group 'notmuch-address) + +;;; Setup + +(defun notmuch-address-selection-function (prompt collection initial-input) + "Default address selection function: delegate to completing read." + (completing-read + prompt collection nil nil initial-input 'notmuch-address-history)) + +(defvar notmuch-address-completion-headers-regexp + "^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):") + +(defvar notmuch-address-history nil) + +(defun notmuch-address-message-insinuate () + (message "calling notmuch-address-message-insinuate is no longer needed")) + +(defun notmuch-address-setup () + (unless (eq notmuch-address-command 'as-is) + (when (and notmuch-address-use-company + (require 'company nil t)) + (notmuch-company-setup)) + (cl-pushnew (cons notmuch-address-completion-headers-regexp + #'notmuch-address-expand-name) + message-completion-alist :test #'equal))) + +(defun notmuch-address-toggle-internal-completion () + "Toggle use of internal completion for current buffer. + +This overrides the global setting for address completion and +toggles the setting in this buffer." + (interactive) + (if (local-variable-p 'notmuch-address-command) + (kill-local-variable 'notmuch-address-command) + (setq-local notmuch-address-command 'internal)) + (when (boundp 'company-idle-delay) + (if (local-variable-p 'company-idle-delay) + (kill-local-variable 'company-idle-delay) + (setq-local company-idle-delay nil)))) + +;;; Completion + +(defun notmuch-address-matching (substring) + "Returns a list of completion candidates matching SUBSTRING. +The candidates are taken from `notmuch-address-completions'." + (let ((candidates) + (re (regexp-quote substring))) + (maphash (lambda (key _val) + (when (string-match re key) + (push key candidates))) + notmuch-address-completions) + candidates)) + +(defun notmuch-address-options (original) + "Return a list of completion candidates. +Use either elisp-based implementation or older implementation +requiring external commands." + (cond + ((eq notmuch-address-command 'internal) + (unless (notmuch-address--harvest-ready) + ;; First, run quick synchronous harvest based on what the user + ;; entered so far. + (notmuch-address-harvest original t)) + (prog1 (notmuch-address-matching original) + ;; Then start the (potentially long-running) full asynchronous + ;; harvest if necessary. + (notmuch-address-harvest-trigger))) + (t + (notmuch--process-lines notmuch-address-command original)))) + +(defun notmuch-address-expand-name () + (cond + ((and (eq notmuch-address-command 'internal) + notmuch-address-use-company + (bound-and-true-p company-mode)) + (company-manual-begin)) + (notmuch-address-command + (let* ((end (point)) + (beg (save-excursion + (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") + (goto-char (match-end 0)) + (point))) + (orig (buffer-substring-no-properties beg end)) + (completion-ignore-case t) + (options (with-temp-message "Looking for completion candidates..." + (notmuch-address-options orig))) + (num-options (length options)) + (chosen (cond + ((eq num-options 0) + nil) + ((eq num-options 1) + (car options)) + (t + (funcall notmuch-address-selection-function + (format "Address (%s matches): " num-options) + options + orig))))) + (if chosen + (progn + (push chosen notmuch-address-history) + (delete-region beg end) + (insert chosen) + (run-hook-with-args 'notmuch-address-post-completion-functions + chosen)) + (message "No matches.") + (ding)))) + (t nil))) + +;;; Harvest + +(defun notmuch-address-harvest-addr (result) + (puthash (plist-get result :name-addr) + t notmuch-address-completions)) + +(defun notmuch-address-harvest-filter (proc string) + (when (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (save-excursion + (goto-char (point-max)) + (insert string)) + (notmuch-sexp-parse-partial-list + 'notmuch-address-harvest-addr (process-buffer proc))))) + +(defvar notmuch-address-harvest-procs '(nil . nil) + "The currently running harvests. + +The car is a partial harvest, and the cdr is a full harvest.") + +(defun notmuch-address-harvest (&optional addr-prefix synchronous callback) + "Collect addresses completion candidates. + +It queries the notmuch database for messages sent/received (as +configured with `notmuch-address-command') by the user, collects +destination/source addresses from those messages and stores them +in `notmuch-address-completions'. + +If ADDR-PREFIX is not nil, only messages with to/from addresses +matching ADDR-PREFIX*' are queried. + +Address harvesting may take some time so the address collection runs +asynchronously unless SYNCHRONOUS is t. In case of asynchronous +execution, CALLBACK is called when harvesting finishes." + (let* ((sent (eq (car notmuch-address-internal-completion) 'sent)) + (config-query (cadr notmuch-address-internal-completion)) + (prefix-query (and addr-prefix + (format "%s:%s*" + (if sent "to" "from") + addr-prefix))) + (from-or-to-me-query + (mapconcat (lambda (x) + (concat (if sent "from:" "to:") x)) + (notmuch-user-emails) " or ")) + (query (if (or prefix-query config-query) + (concat (format "(%s)" from-or-to-me-query) + (and prefix-query + (format " and (%s)" prefix-query)) + (and config-query + (format " and (%s)" config-query))) + from-or-to-me-query)) + (args `("address" "--format=sexp" "--format-version=5" + ,(if sent "--output=recipients" "--output=sender") + "--deduplicate=address" + ,query))) + (if synchronous + (mapc #'notmuch-address-harvest-addr + (apply 'notmuch-call-notmuch-sexp args)) + ;; Asynchronous + (let* ((current-proc (if addr-prefix + (car notmuch-address-harvest-procs) + (cdr notmuch-address-harvest-procs))) + (proc-name (format "notmuch-address-%s-harvest" + (if addr-prefix "partial" "full"))) + (proc-buf (concat " *" proc-name "*"))) + ;; Kill any existing process + (when current-proc + (kill-buffer (process-buffer current-proc))) ; this also kills the process + (setq current-proc + (apply 'notmuch-start-notmuch proc-name proc-buf + callback ; process sentinel + args)) + (set-process-filter current-proc 'notmuch-address-harvest-filter) + (set-process-query-on-exit-flag current-proc nil) + (if addr-prefix + (setcar notmuch-address-harvest-procs current-proc) + (setcdr notmuch-address-harvest-procs current-proc))))) + ;; return value + nil) + +(defvar notmuch-address--save-hash-version 1 + "Version format of the save hash.") + +(defun notmuch-address--get-address-hash () + "Return the saved address hash as a plist. + +Returns nil if the save file does not exist, or it does not seem +to be a saved address hash." + (and notmuch-address-save-filename + (condition-case nil + (with-temp-buffer + (insert-file-contents notmuch-address-save-filename) + (let ((name (read (current-buffer))) + (plist (read (current-buffer)))) + ;; We do two simple sanity checks on the loaded file. + ;; We just check a version is specified, not that + ;; it is the current version, as we are allowed to + ;; over-write and a save-file with an older version. + (and (string= name "notmuch-address-hash") + (plist-get plist :version) + plist))) + ;; The error case catches any of the reads failing. + (error nil)))) + +(defun notmuch-address--load-address-hash () + "Read the saved address hash and set the corresponding variables." + (let ((load-plist (notmuch-address--get-address-hash))) + (when (and load-plist + ;; If the user's setting have changed, or the version + ;; has changed, return nil to make sure the new settings + ;; take effect. + (equal (plist-get load-plist :completion-settings) + notmuch-address-internal-completion) + (equal (plist-get load-plist :version) + notmuch-address--save-hash-version)) + (setq notmuch-address-last-harvest (plist-get load-plist :last-harvest)) + (setq notmuch-address-completions (plist-get load-plist :completions)) + (setq notmuch-address-full-harvest-finished t) + ;; Return t to say load was successful. + t))) + +(defun notmuch-address--save-address-hash () + (when notmuch-address-save-filename + (if (or (not (file-exists-p notmuch-address-save-filename)) + ;; The file exists, check it is a file we saved. + (notmuch-address--get-address-hash)) + (with-temp-file notmuch-address-save-filename + (let ((save-plist + (list :version notmuch-address--save-hash-version + :completion-settings notmuch-address-internal-completion + :last-harvest notmuch-address-last-harvest + :completions notmuch-address-completions))) + (print "notmuch-address-hash" (current-buffer)) + (print save-plist (current-buffer)))) + (message "\ +Warning: notmuch-address-save-filename %s exists but doesn't +appear to be an address savefile. Not overwriting." + notmuch-address-save-filename)))) + +(defun notmuch-address-harvest-trigger () + (let ((now (float-time))) + (when (> (- now notmuch-address-last-harvest) 86400) + (setq notmuch-address-last-harvest now) + (notmuch-address-harvest + nil nil + (lambda (_proc event) + ;; If harvest fails, we want to try + ;; again when the trigger is next called. + (if (string= event "finished\n") + (progn + (notmuch-address--save-address-hash) + (setq notmuch-address-full-harvest-finished t)) + (setq notmuch-address-last-harvest 0))))))) + +;;; Standalone completion + +(defun notmuch-address-from-minibuffer (prompt) + (if (not notmuch-address-command) + (read-string prompt) + (let ((rmap (copy-keymap minibuffer-local-map)) + (omap minibuffer-local-map)) + ;; Configure TAB to start completion when executing read-string. + ;; "Original" minibuffer keymap is restored just before calling + ;; notmuch-address-expand-name as it may also use minibuffer-local-map + ;; (completing-read probably does not but if something else is used there). + (define-key rmap (kbd "TAB") (lambda () + (interactive) + (let ((enable-recursive-minibuffers t) + (minibuffer-local-map omap)) + (notmuch-address-expand-name)))) + (let ((minibuffer-local-map rmap)) + (read-string prompt))))) + +;;; _ + +(provide 'notmuch-address) + +;;; notmuch-address.el ends here blob - /dev/null blob + 08a4354a0e8b74079d28bbde4dc4e39ecbca9a2a (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-autoloads.el @@ -0,0 +1,254 @@ +;;; notmuch-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from coolj.el + +(register-definition-prefixes "coolj" '("coolj-")) + + +;;; Generated autoloads from make-deps.el + +(register-definition-prefixes "make-deps" '("batch-make-deps" "make-deps")) + + +;;; Generated autoloads from notmuch.el + +(autoload 'notmuch-search "notmuch" "\ +Display threads matching QUERY in a notmuch-search buffer. + +If QUERY is nil, it is read interactively from the minibuffer. +Other optional parameters are used as follows: + + OLDEST-FIRST: A Boolean controlling the sort order of returned threads + HIDE-EXCLUDED: A boolean controlling whether to omit threads with excluded + tags. + TARGET-THREAD: A thread ID (without the thread: prefix) that will be made + current if it appears in the search results. + TARGET-LINE: The line number to move to if the target thread does not + appear in the search results. + NO-DISPLAY: Do not try to foreground the search results buffer. If it is + already foregrounded i.e. displayed in a window, this has no + effect, meaning the buffer will remain visible. + +When called interactively, this will prompt for a query and use +the configured default sort order. + +(fn &optional QUERY OLDEST-FIRST HIDE-EXCLUDED TARGET-THREAD TARGET-LINE NO-DISPLAY)" t) +(autoload 'notmuch "notmuch" "\ +Run notmuch and display saved searches, known tags, etc." t) +(autoload 'notmuch-cycle-notmuch-buffers "notmuch" "\ +Cycle through any existing notmuch buffers (search, show or hello). + +If the current buffer is the only notmuch buffer, bury it. +If no notmuch buffers exist, run `notmuch'." t) +(register-definition-prefixes "notmuch" '("notmuch-")) + + +;;; Generated autoloads from notmuch-address.el + +(register-definition-prefixes "notmuch-address" '("notmuch-address-")) + + +;;; Generated autoloads from notmuch-company.el + +(autoload 'notmuch-company-setup "notmuch-company") +(autoload 'notmuch-company "notmuch-company" "\ +`company-mode' completion back-end for `notmuch'. + +(fn COMMAND &optional ARG &rest IGNORE)" t) +(register-definition-prefixes "notmuch-company" '("notmuch-company-last-prefix")) + + +;;; Generated autoloads from notmuch-compat.el + +(register-definition-prefixes "notmuch-compat" '("notmuch-")) + + +;;; Generated autoloads from notmuch-crypto.el + +(register-definition-prefixes "notmuch-crypto" '("notmuch-crypto-")) + + +;;; Generated autoloads from notmuch-draft.el + +(register-definition-prefixes "notmuch-draft" '("notmuch-draft-")) + + +;;; Generated autoloads from notmuch-hello.el + +(autoload 'notmuch-hello "notmuch-hello" "\ +Run notmuch and display saved searches, known tags, etc. + +(fn &optional NO-DISPLAY)" t) +(register-definition-prefixes "notmuch-hello" '("notmuch-")) + + +;;; Generated autoloads from notmuch-jump.el + +(autoload 'notmuch-jump-search "notmuch-jump" "\ +Jump to a saved search by shortcut key. + +This prompts for and performs a saved search using the shortcut +keys configured in the :key property of `notmuch-saved-searches'. +Typically these shortcuts are a single key long, so this is a +fast way to jump to a saved search from anywhere in Notmuch." t) +(autoload 'notmuch-jump "notmuch-jump" "\ +Interactively prompt for one of the keys in ACTION-MAP. + +Displays a summary of all bindings in ACTION-MAP in the +minibuffer, reads a key from the minibuffer, and performs the +corresponding action. The prompt can be canceled with C-g or +RET. PROMPT must be a string to use for the prompt. PROMPT +should include a space at the end. + +ACTION-MAP must be a list of triples of the form + (KEY LABEL ACTION) +where KEY is a key binding, LABEL is a string label to display in +the buffer, and ACTION is a nullary function to call. LABEL may +be null, in which case the action will still be bound, but will +not appear in the pop-up buffer. + +(fn ACTION-MAP PROMPT)") +(register-definition-prefixes "notmuch-jump" '("notmuch-jump-")) + + +;;; Generated autoloads from notmuch-lib.el + +(register-definition-prefixes "notmuch-lib" '("notmuch-")) + + +;;; Generated autoloads from notmuch-maildir-fcc.el + +(register-definition-prefixes "notmuch-maildir-fcc" '("notmuch-" "with-temporary-notmuch-message-buffer")) + + +;;; Generated autoloads from notmuch-message.el + +(register-definition-prefixes "notmuch-message" '("notmuch-message-")) + + +;;; Generated autoloads from notmuch-mua.el + +(autoload 'notmuch-mua-mail "notmuch-mua" "\ +Invoke the notmuch mail composition window. + +The position of point when the function returns differs depending +on the values of TO and SUBJECT. If both are non-nil, point is +moved to the message's body. If SUBJECT is nil but TO isn't, +point is moved to the \"Subject:\" header. Otherwise, point is +moved to the \"To:\" header. + +(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest IGNORED)" t) +(autoload 'notmuch-mua-send-and-exit "notmuch-mua" "\ + + +(fn &optional ARG)" t) +(autoload 'notmuch-mua-send "notmuch-mua" "\ + + +(fn &optional ARG)" t) +(autoload 'notmuch-mua-kill-buffer "notmuch-mua" nil t) +(define-mail-user-agent 'notmuch-user-agent 'notmuch-mua-mail 'notmuch-mua-send-and-exit 'notmuch-mua-kill-buffer 'notmuch-mua-send-hook) +(register-definition-prefixes "notmuch-mua" '("notmuch-")) + + +;;; Generated autoloads from notmuch-parser.el + +(register-definition-prefixes "notmuch-parser" '("notmuch-sexp-")) + + +;;; Generated autoloads from notmuch-print.el + +(register-definition-prefixes "notmuch-print" '("notmuch-print-")) + + +;;; Generated autoloads from notmuch-query.el + +(register-definition-prefixes "notmuch-query" '("notmuch-query-")) + + +;;; Generated autoloads from notmuch-show.el + +(autoload 'notmuch-show "notmuch-show" "\ +Run \"notmuch show\" with the given thread ID and display results. + +ELIDE-TOGGLE, if non-nil, inverts the default elide behavior. + +The optional PARENT-BUFFER is the notmuch-search buffer from +which this notmuch-show command was executed, (so that the +next thread from that buffer can be show when done with this +one). + +The optional QUERY-CONTEXT is a notmuch search term. Only +messages from the thread matching this search term are shown if +non-nil. + +The optional BUFFER-NAME provides the name of the buffer in +which the message thread is shown. If it is nil (which occurs +when the command is called interactively) the argument to the +function is used. + +Returns the buffer containing the messages, or NIL if no messages +matched. + +(fn THREAD-ID &optional ELIDE-TOGGLE PARENT-BUFFER QUERY-CONTEXT BUFFER-NAME)" t) +(register-definition-prefixes "notmuch-show" '("notmuch-" "with-current-notmuch-show-message")) + + +;;; Generated autoloads from notmuch-tag.el + +(register-definition-prefixes "notmuch-tag" '("notmuch-")) + + +;;; Generated autoloads from notmuch-tree.el + +(autoload 'notmuch-tree "notmuch-tree" "\ +Display threads matching QUERY in tree view. + +The arguments are: + QUERY: the main query. This can be any query but in many cases will be + a single thread. If nil this is read interactively from the minibuffer. + QUERY-CONTEXT: is an additional term for the query. The query used + is QUERY and QUERY-CONTEXT unless that does not match any messages + in which case we fall back to just QUERY. + TARGET: A message ID (with the id: prefix) that will be made + current if it appears in the tree view results. + BUFFER-NAME: the name of the buffer to display the tree view. If + it is nil \"*notmuch-tree\" followed by QUERY is used. + OPEN-TARGET: If TRUE open the target message in the message pane. + UNTHREADED: If TRUE only show matching messages in an unthreaded view. + +(fn &optional QUERY QUERY-CONTEXT TARGET BUFFER-NAME OPEN-TARGET UNTHREADED PARENT-BUFFER OLDEST-FIRST HIDE-EXCLUDED)" t) +(register-definition-prefixes "notmuch-tree" '("notmuch-")) + + +;;; Generated autoloads from notmuch-wash.el + +(register-definition-prefixes "notmuch-wash" '("notmuch-wash-")) + + +;;; Generated autoloads from rstdoc.el + +(register-definition-prefixes "rstdoc" '("rst")) + +;;; End of scraped data + +(provide 'notmuch-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; notmuch-autoloads.el ends here blob - /dev/null blob + 7e05dc8f2a796aaf2c664fdcc4be63f6a443057f (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-company.el @@ -0,0 +1,106 @@ +;;; notmuch-company.el --- Mail address completion for notmuch via company-mode -*- lexical-binding: t -*- +;; +;; Copyright © Trevor Jim +;; Copyright © Michal Sojka +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Trevor Jim +;; Michal Sojka +;; Keywords: mail, completion + +;;; Commentary: + +;; Mail address completion for notmuch via company-mode. To enable +;; this, install company mode from . +;; +;; NB company-minimum-prefix-length defaults to 3 so you don't get +;; completion unless you type 3 characters. + +;;; Code: + +(require 'notmuch-lib) + +(defvar-local notmuch-company-last-prefix nil) + +(declare-function company-begin-backend "company") +(declare-function company-grab "company") +(declare-function company-mode "company") +(declare-function company-manual-begin "company") +(defvar company-backends) +(defvar company-idle-delay) + +(declare-function notmuch-address-harvest "notmuch-address") +(declare-function notmuch-address-harvest-trigger "notmuch-address") +(declare-function notmuch-address-matching "notmuch-address") +(declare-function notmuch-address--harvest-ready "notmuch-address") +(defvar notmuch-address-completion-headers-regexp) +(defvar notmuch-address-command) + +;;;###autoload +(defun notmuch-company-setup () + (company-mode) + (setq-local company-backends '(notmuch-company)) + ;; Disable automatic company completion unless an internal + ;; completion method is configured. Company completion (using + ;; internal completion) can still be accessed via standard company + ;; functions, e.g., company-complete. + (unless (eq notmuch-address-command 'internal) + (setq-local company-idle-delay nil))) + +;;;###autoload +(defun notmuch-company (command &optional arg &rest _ignore) + "`company-mode' completion back-end for `notmuch'." + (interactive (list 'interactive)) + (require 'company) + (let ((case-fold-search t) + (completion-ignore-case t)) + (cl-case command + (interactive (company-begin-backend 'notmuch-company)) + (prefix (and (or (derived-mode-p 'message-mode) + (derived-mode-p 'org-msg-edit-mode)) + (looking-back + (concat notmuch-address-completion-headers-regexp ".*") + (line-beginning-position)) + (setq notmuch-company-last-prefix + (company-grab "[:,][ \t]*\\(.*\\)" 1 (point-at-bol))))) + (candidates (cond + ((notmuch-address--harvest-ready) + ;; Update harvested addressed from time to time + (notmuch-address-harvest-trigger) + (notmuch-address-matching arg)) + (t + (cons :async + (lambda (callback) + ;; First run quick asynchronous harvest + ;; based on what the user entered so far + (notmuch-address-harvest + arg nil + (lambda (_proc _event) + (funcall callback (notmuch-address-matching arg)) + ;; Then start the (potentially long-running) + ;; full asynchronous harvest if necessary + (notmuch-address-harvest-trigger)))))))) + (match (if (string-match notmuch-company-last-prefix arg) + (match-end 0) + 0)) + (post-completion + (run-hook-with-args 'notmuch-address-post-completion-functions arg)) + (no-cache t)))) + +(provide 'notmuch-company) + +;;; notmuch-company.el ends here blob - /dev/null blob + 179bf59ca86116e79b64393ff76c41d65db53be9 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-compat.el @@ -0,0 +1,58 @@ +;;; notmuch-compat.el --- compatibility functions for earlier versions of emacs -*- lexical-binding: t -*- +;; +;; The functions in this file are copied from more modern versions of +;; emacs and are Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2017 +;; Free Software Foundation, Inc. +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . + +;;; Code: + +;; Before Emacs 26.1 lines that are longer than 998 octets were not. +;; folded. Commit 77bbca8c82f6e553c42abbfafca28f55fc995d00 fixed +;; that. Until we drop support for Emacs 25 we have to backport that +;; fix. To avoid interfering with Gnus we only run the hook when +;; called from notmuch-message-mode. + +(declare-function mail-header-fold-field "mail-parse" nil) + +(defun notmuch-message--fold-long-headers () + (when (eq major-mode 'notmuch-message-mode) + (goto-char (point-min)) + (while (not (eobp)) + (when (and (looking-at "[^:]+:") + (> (- (line-end-position) (point)) 998)) + (mail-header-fold-field)) + (forward-line 1)))) + +(unless (fboundp 'message--fold-long-headers) + (add-hook 'message-header-hook 'notmuch-message--fold-long-headers)) + +;; `dlet' isn't available until Emacs 28.1. Below is a copy, with the +;; addition of `with-no-warnings'. +(defmacro notmuch-dlet (binders &rest body) + "Like `let*' but using dynamic scoping." + (declare (indent 1) (debug let)) + `(let (_) + (with-no-warnings ; Quiet "lacks a prefix" warning. + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders)) + (let* ,binders ,@body))) + +(provide 'notmuch-compat) + +;;; notmuch-compat.el ends here blob - /dev/null blob + a1cf3ddd93e176748e49472750c6138c76c4b27a (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-crypto.el @@ -0,0 +1,272 @@ +;;; notmuch-crypto.el --- functions for handling display of cryptographic metadata -*- lexical-binding: t -*- +;; +;; Copyright © Jameson Rollins +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Jameson Rollins + +;;; Code: + +(require 'epg) +(require 'notmuch-lib) + +(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare)) + +;;; Options + +(defcustom notmuch-crypto-process-mime t + "Whether to process cryptographic MIME parts. + +If this variable is non-nil signatures in multipart/signed +messages will be verified and multipart/encrypted parts will be +decrypted. The result of the crypto operation will be displayed +in a specially colored header button at the top of the processed +part. Signed parts will have variously colored headers depending +on the success or failure of the verification process and on the +validity of user ID of the signer. + +The effect of setting this variable can be seen temporarily by +providing a prefix when viewing a signed or encrypted message, or +by providing a prefix when reloading the message in notmuch-show +mode." + :type 'boolean + :package-version '(notmuch . "0.25") + :group 'notmuch-crypto) + +(defcustom notmuch-crypto-get-keys-asynchronously t + "Whether to retrieve openpgp keys asynchronously." + :type 'boolean + :group 'notmuch-crypto) + +(defcustom notmuch-crypto-gpg-program epg-gpg-program + "The gpg executable." + :type 'string + :group 'notmuch-crypto) + +;;; Faces + +(defface notmuch-crypto-part-header + '((((class color) + (background dark)) + (:foreground "LightBlue1")) + (((class color) + (background light)) + (:foreground "blue"))) + "Face used for crypto parts headers." + :group 'notmuch-crypto + :group 'notmuch-faces) + +(defface notmuch-crypto-signature-good + '((t (:background "green" :foreground "black"))) + "Face used for good signatures." + :group 'notmuch-crypto + :group 'notmuch-faces) + +(defface notmuch-crypto-signature-good-key + '((t (:background "orange" :foreground "black"))) + "Face used for good signatures." + :group 'notmuch-crypto + :group 'notmuch-faces) + +(defface notmuch-crypto-signature-bad + '((t (:background "red" :foreground "black"))) + "Face used for bad signatures." + :group 'notmuch-crypto + :group 'notmuch-faces) + +(defface notmuch-crypto-signature-unknown + '((t (:background "red" :foreground "black"))) + "Face used for signatures of unknown status." + :group 'notmuch-crypto + :group 'notmuch-faces) + +(defface notmuch-crypto-decryption + '((t (:background "purple" :foreground "black"))) + "Face used for encryption/decryption status messages." + :group 'notmuch-crypto + :group 'notmuch-faces) + +;;; Functions + +(define-button-type 'notmuch-crypto-status-button-type + 'action (lambda (button) (message "%s" (button-get button 'help-echo))) + 'follow-link t + 'help-echo "Set notmuch-crypto-process-mime to process cryptographic mime parts." + :supertype 'notmuch-button-type) + +(defun notmuch-crypto-insert-sigstatus-button (sigstatus from) + "Insert a button describing the signature status SIGSTATUS sent by user FROM." + (let* ((status (plist-get sigstatus :status)) + (show-button t) + (face 'notmuch-crypto-signature-unknown) + (button-action (lambda (button) (message (button-get button 'help-echo)))) + (keyid (concat "0x" (plist-get sigstatus :keyid))) + label help-msg) + (cond + ((string= status "good") + (let ((fingerprint (concat "0x" (plist-get sigstatus :fingerprint))) + (email-or-userid (or (plist-get sigstatus :email) + (plist-get sigstatus :userid)))) + ;; If email or userid are present, they have full or greater validity. + (setq label (concat "Good signature by key: " fingerprint)) + (setq face 'notmuch-crypto-signature-good-key) + (when email-or-userid + (setq label (concat "Good signature by: " email-or-userid)) + (setq face 'notmuch-crypto-signature-good)) + (setq button-action 'notmuch-crypto-sigstatus-good-callback) + (setq help-msg (concat "Click to list key ID 0x" fingerprint ".")))) + ((string= status "error") + (setq label (concat "Unknown key ID " keyid " or unsupported algorithm")) + (setq button-action 'notmuch-crypto-sigstatus-error-callback) + (setq help-msg (concat "Click to retrieve key ID " keyid + " from key server."))) + ((string= status "bad") + (setq label (concat "Bad signature (claimed key ID " keyid ")")) + (setq face 'notmuch-crypto-signature-bad)) + (status + (setq label (concat "Unknown signature status: " status))) + (t + (setq show-button nil))) + (when show-button + (insert-button + (concat "[ " label " ]") + :type 'notmuch-crypto-status-button-type + 'help-echo help-msg + 'face face + 'mouse-face face + 'action button-action + :notmuch-sigstatus sigstatus + :notmuch-from from) + (insert "\n")))) + +(defun notmuch-crypto-sigstatus-good-callback (button) + (let* ((id (notmuch-show-get-message-id)) + (sigstatus (button-get button :notmuch-sigstatus)) + (fingerprint (concat "0x" (plist-get sigstatus :fingerprint))) + (buffer (get-buffer-create "*notmuch-crypto-gpg-out*")) + (window (display-buffer buffer))) + (with-selected-window window + (with-current-buffer buffer + (goto-char (point-max)) + (insert (format "-- Key %s in message %s:\n" + fingerprint id)) + (notmuch--call-process notmuch-crypto-gpg-program nil t t + "--batch" "--no-tty" "--list-keys" fingerprint)) + (recenter -1)))) + +(declare-function notmuch-show-refresh-view "notmuch-show" (&optional reset-state)) +(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare)) + +(defun notmuch-crypto--async-key-sentinel (process _event) + "When the user asks for a GPG key to be retrieved +asynchronously, handle completion of that task. + +If the retrieval is successful, the thread where the retrieval +was initiated is still displayed and the cursor has not moved, +redisplay the thread." + (let ((status (process-status process)) + (exit-status (process-exit-status process)) + (keyid (process-get process :gpg-key-id))) + (when (memq status '(exit signal)) + (message "Getting the GPG key %s asynchronously...%s." + keyid + (if (= exit-status 0) + "completed" + "failed")) + ;; If the original buffer is still alive and point didn't move + ;; (i.e. the user didn't move on or away), refresh the buffer to + ;; show the updated signature status. + (let ((show-buffer (process-get process :notmuch-show-buffer)) + (show-point (process-get process :notmuch-show-point))) + (when (and (bufferp show-buffer) + (buffer-live-p show-buffer) + (= show-point + (with-current-buffer show-buffer + (point)))) + (with-current-buffer show-buffer + (notmuch-show-refresh-view))))))) + +(defun notmuch-crypto--set-button-label (button label) + "Set the text displayed in BUTTON to LABEL." + (save-excursion + (let ((inhibit-read-only t)) + ;; This knows rather too much about how we typically format + ;; buttons. + (goto-char (button-start button)) + (forward-char 2) + (delete-region (point) (- (button-end button) 2)) + (insert label)))) + +(defun notmuch-crypto-sigstatus-error-callback (button) + "When signature validation has failed, try to retrieve the +corresponding key when the status button is pressed." + (let* ((sigstatus (button-get button :notmuch-sigstatus)) + (keyid (concat "0x" (plist-get sigstatus :keyid))) + (buffer (get-buffer-create "*notmuch-crypto-gpg-out*"))) + (if notmuch-crypto-get-keys-asynchronously + (progn + (notmuch-crypto--set-button-label + button (format "Retrieving key %s asynchronously..." keyid)) + (with-current-buffer buffer + (goto-char (point-max)) + (insert (format "--- Retrieving key %s:\n" keyid))) + (let ((p (notmuch--make-process + :name "notmuch GPG key retrieval" + :connection-type 'pipe + :buffer buffer + :stderr buffer + :command (list notmuch-crypto-gpg-program "--recv-keys" keyid) + :sentinel #'notmuch-crypto--async-key-sentinel))) + (process-put p :gpg-key-id keyid) + (process-put p :notmuch-show-buffer (current-buffer)) + (process-put p :notmuch-show-point (point)) + (message "Getting the GPG key %s asynchronously..." keyid))) + (let ((window (display-buffer buffer))) + (with-selected-window window + (with-current-buffer buffer + (goto-char (point-max)) + (insert (format "--- Retrieving key %s:\n" keyid)) + (notmuch--call-process notmuch-crypto-gpg-program nil t t "--recv-keys" keyid) + (insert "\n") + (notmuch--call-process notmuch-crypto-gpg-program nil t t "--list-keys" keyid)) + (recenter -1)) + (notmuch-show-refresh-view))))) + +(defun notmuch-crypto-insert-encstatus-button (encstatus) + "Insert a button describing the encryption status ENCSTATUS." + (insert-button + (concat "[ " + (let ((status (plist-get encstatus :status))) + (cond + ((string= status "good") + "Decryption successful") + ((string= status "bad") + "Decryption error") + (t + (concat "Unknown encryption status" + (and status (concat ": " status)))))) + " ]") + :type 'notmuch-crypto-status-button-type + 'face 'notmuch-crypto-decryption + 'mouse-face 'notmuch-crypto-decryption) + (insert "\n")) + +;;; _ + +(provide 'notmuch-crypto) + +;;; notmuch-crypto.el ends here blob - /dev/null blob + fcc45503c6b0816d4ab12ab98a6c86cf6b2d3eb9 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-draft.el @@ -0,0 +1,287 @@ +;;; notmuch-draft.el --- functions for postponing and editing drafts -*- lexical-binding: t -*- +;; +;; Copyright © Mark Walters +;; Copyright © David Bremner +;; Copyright © Leo Gaspard +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Mark Walters +;; David Bremner +;; Leo Gaspard + +;;; Code: + +(require 'cl-lib) +(require 'pcase) +(require 'subr-x) + +(require 'notmuch-maildir-fcc) +(require 'notmuch-tag) + +(declare-function notmuch-show-get-message-id "notmuch-show" (&optional bare)) +(declare-function notmuch-message-mode "notmuch-mua") + +;;; Options + +(defgroup notmuch-draft nil + "Saving and editing drafts in Notmuch." + :group 'notmuch) + +(defcustom notmuch-draft-tags '("+draft") + "List of tag changes to apply when saving a draft message in the database. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message being stored. + +For example, if you wanted to give the message a \"draft\" tag +but not the (normally added by default) \"inbox\" tag, you would +set: + (\"+draft\" \"-inbox\")" + :type '(repeat string) + :group 'notmuch-draft) + +(defcustom notmuch-draft-folder "drafts" + "Folder to save draft messages in. + +This should be specified relative to the root of the notmuch +database. It will be created if necessary." + :type 'string + :group 'notmuch-draft) + +(defcustom notmuch-draft-quoted-tags '() + "Mml tags to quote. + +This should be a list of mml tags to quote before saving. You do +not need to include \"secure\" as that is handled separately. + +If you include \"part\" then attachments will not be saved with +the draft -- if not then they will be saved with the draft. The +former means the attachments may not still exist when you resume +the message, the latter means that the attachments as they were +when you postponed will be sent with the resumed message. + +Note you may get strange results if you change this between +postponing and resuming a message." + :type '(repeat string) + :group 'notmuch-send) + +(defcustom notmuch-draft-save-plaintext 'ask + "Whether to allow saving plaintext when it seems encryption is intended. +When a message contains mml tags, then that suggest it is +intended to be encrypted. If the user requests that such a +message is saved locally, then this option controls whether +that is allowed. Beside a boolean, this can also be `ask'." + :type '(radio + (const :tag "Never" nil) + (const :tag "Ask every time" ask) + (const :tag "Always" t)) + :group 'notmuch-draft + :group 'notmuch-crypto) + +;;; Internal + +(defvar notmuch-draft-encryption-tag-regex + "<#\\(part encrypt\\|secure.*mode=.*encrypt>\\)" + "Regular expression matching mml tags indicating encryption of part or message.") + +(defvar-local notmuch-draft-id nil + "Message-id of the most recent saved draft of this message.") + +(defun notmuch-draft--mark-deleted () + "Tag the last saved draft deleted. + +Used when a new version is saved, or the message is sent." + (when notmuch-draft-id + (notmuch-tag notmuch-draft-id '("+deleted")))) + +(defun notmuch-draft-quote-some-mml () + "Quote the mml tags in `notmuch-draft-quoted-tags'." + (save-excursion + ;; First we deal with any secure tag separately. + (message-goto-body) + (when (looking-at "<#secure[^\n]*>\n") + (let ((secure-tag (match-string 0))) + (delete-region (match-beginning 0) (match-end 0)) + (message-add-header (concat "X-Notmuch-Emacs-Secure: " secure-tag)))) + ;; This is copied from mml-quote-region but only quotes the + ;; specified tags. + (when notmuch-draft-quoted-tags + (let ((re (concat "<#!*/?\\(" + (mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|") + "\\)"))) + (message-goto-body) + (while (re-search-forward re nil t) + ;; Insert ! after the #. + (goto-char (+ (match-beginning 0) 2)) + (insert "!")))))) + +(defun notmuch-draft-unquote-some-mml () + "Unquote the mml tags in `notmuch-draft-quoted-tags'." + (save-excursion + (when notmuch-draft-quoted-tags + (let ((re (concat "<#!+/?\\(" + (mapconcat 'regexp-quote notmuch-draft-quoted-tags "\\|") + "\\)"))) + (message-goto-body) + (while (re-search-forward re nil t) + ;; Remove one ! from after the #. + (goto-char (+ (match-beginning 0) 2)) + (delete-char 1)))) + (let (secure-tag) + (save-restriction + (message-narrow-to-headers) + (setq secure-tag (message-fetch-field "X-Notmuch-Emacs-Secure" t)) + (message-remove-header "X-Notmuch-Emacs-Secure")) + (message-goto-body) + (when secure-tag + (insert secure-tag "\n"))))) + +(defun notmuch-draft--has-encryption-tag () + "Return non-nil if there is an mml secure tag." + (save-excursion + (message-goto-body) + (re-search-forward notmuch-draft-encryption-tag-regex nil t))) + +(defun notmuch-draft--query-encryption () + "Return non-nil if we should save a message that should be encrypted. + +`notmuch-draft-save-plaintext' controls the behaviour." + (cl-case notmuch-draft-save-plaintext + ((ask) + (unless (yes-or-no-p + "(Customize `notmuch-draft-save-plaintext' to avoid this warning) +This message contains mml tags that suggest it is intended to be encrypted. +Really save and index an unencrypted copy? ") + (error "Save aborted"))) + ((nil) + (error "Refusing to save draft with encryption tags (see `%s')" + 'notmuch-draft-save-plaintext)) + ((t) + (ignore)))) + +(defun notmuch-draft--make-message-id () + ;; message-make-message-id gives the id inside a "<" ">" pair, + ;; but notmuch doesn't want that form, so remove them. + (concat "draft-" (substring (message-make-message-id) 1 -1))) + +;;; Commands + +(defun notmuch-draft-save () + "Save the current draft message in the notmuch database. + +This saves the current message in the database with tags +`notmuch-draft-tags' (in addition to any default tags +applied to newly inserted messages)." + (interactive) + (when (notmuch-draft--has-encryption-tag) + (notmuch-draft--query-encryption)) + (let ((id (notmuch-draft--make-message-id))) + (with-temporary-notmuch-message-buffer + ;; We insert a Date header and a Message-ID header, the former + ;; so that it is easier to search for the message, and the + ;; latter so we have a way of accessing the saved message (for + ;; example to delete it at a later time). We check that the + ;; user has these in `message-deletable-headers' (the default) + ;; as otherwise they are doing something strange and we + ;; shouldn't interfere. Note, since we are doing this in a new + ;; buffer we don't change the version in the compose buffer. + (cond + ((member 'Message-ID message-deletable-headers) + (message-remove-header "Message-ID") + (message-add-header (concat "Message-ID: <" id ">"))) + (t + (message "You have customized emacs so Message-ID is not a %s" + "deletable header, so not changing it") + (setq id nil))) + (cond + ((member 'Date message-deletable-headers) + (message-remove-header "Date") + (message-add-header (concat "Date: " (message-make-date)))) + (t + (message "You have customized emacs so Date is not a deletable %s" + "header, so not changing it"))) + (message-add-header "X-Notmuch-Emacs-Draft: True") + (notmuch-draft-quote-some-mml) + (notmuch-maildir-setup-message-for-saving) + (notmuch-maildir-notmuch-insert-current-buffer + notmuch-draft-folder t notmuch-draft-tags)) + ;; We are now back in the original compose buffer. Note the + ;; function notmuch-call-notmuch-process (called by + ;; notmuch-maildir-notmuch-insert-current-buffer) signals an error + ;; on failure, so to get to this point it must have + ;; succeeded. Also, notmuch-draft-id is still the id of the + ;; previous draft, so it is safe to mark it deleted. + (notmuch-draft--mark-deleted) + (setq notmuch-draft-id (concat "id:" id)) + (set-buffer-modified-p nil))) + +(defun notmuch-draft-postpone () + "Save the draft message in the notmuch database and exit buffer." + (interactive) + (notmuch-draft-save) + (kill-buffer)) + +(defun notmuch-draft-resume (id) + "Resume editing of message with id ID." + ;; Used by command `notmuch-show-resume-message'. + (let* ((tags (notmuch--process-lines notmuch-command "search" "--output=tags" + "--exclude=false" id)) + (draft (equal tags (notmuch-update-tags tags notmuch-draft-tags)))) + (when (or draft + (yes-or-no-p "Message does not appear to be a draft: edit as new? ")) + (pop-to-buffer-same-window + (get-buffer-create (concat "*notmuch-draft-" id "*"))) + (setq buffer-read-only nil) + (erase-buffer) + (let ((coding-system-for-read 'no-conversion)) + (notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id)) + (mime-to-mml) + (goto-char (point-min)) + (when (re-search-forward "^$" nil t) + (replace-match mail-header-separator t t)) + ;; Remove the Date and Message-ID headers (unless the user has + ;; explicitly customized emacs to tell us not to) as they will + ;; be replaced when the message is sent. + (save-restriction + (message-narrow-to-headers) + (when (member 'Message-ID message-deletable-headers) + (message-remove-header "Message-ID")) + (when (member 'Date message-deletable-headers) + (message-remove-header "Date")) + (unless draft (notmuch-fcc-header-setup)) + ;; The X-Notmuch-Emacs-Draft header is a more reliable + ;; indication of whether the message really is a draft. + (setq draft (> (message-remove-header "X-Notmuch-Emacs-Draft") 0))) + ;; If the message is not a draft we should not unquote any mml. + (when draft + (notmuch-draft-unquote-some-mml)) + (notmuch-message-mode) + (message-goto-body) + (set-buffer-modified-p nil) + ;; If the resumed message was a draft then set the draft + ;; message-id so that we can delete the current saved draft if the + ;; message is resaved or sent. + (setq notmuch-draft-id (and draft id))))) + +;;; _ + +(add-hook 'message-send-hook 'notmuch-draft--mark-deleted) + +(provide 'notmuch-draft) + +;;; notmuch-draft.el ends here blob - /dev/null blob + 67c805a8549fd3f6d7eb0e9cff1e9f37b1c9be36 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-hello.el @@ -0,0 +1,1029 @@ +;;; notmuch-hello.el --- welcome to notmuch, a frontend -*- lexical-binding: t -*- +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Edmondson + +;;; Code: + +(require 'widget) +(require 'wid-edit) ; For `widget-forward'. + +(require 'notmuch-lib) +(require 'notmuch-mua) + +(declare-function notmuch-search "notmuch" + (&optional query oldest-first target-thread target-line + no-display)) +(declare-function notmuch-poll "notmuch-lib" ()) +(declare-function notmuch-tree "notmuch-tree" + (&optional query query-context target buffer-name + open-target unthreaded parent-buffer + oldest-first hide-excluded)) +(declare-function notmuch-unthreaded "notmuch-tree" + (&optional query query-context target buffer-name + open-target oldest-first hide-excluded)) + + +;;; Options + +(defun notmuch-saved-search-get (saved-search field) + "Get FIELD from SAVED-SEARCH. + +If SAVED-SEARCH is a plist, this is just `plist-get', but for +backwards compatibility, this also deals with the two other +possible formats for SAVED-SEARCH: cons cells (NAME . QUERY) and +lists (NAME QUERY COUNT-QUERY)." + (cond + ((keywordp (car saved-search)) + (plist-get saved-search field)) + ;; It is not a plist so it is an old-style entry. + ((consp (cdr saved-search)) + (pcase-let ((`(,name ,query ,count-query) saved-search)) + (cl-case field + (:name name) + (:query query) + (:count-query count-query) + (t nil)))) + (t + (pcase-let ((`(,name . ,query) saved-search)) + (cl-case field + (:name name) + (:query query) + (t nil)))))) + +(defun notmuch-hello-saved-search-to-plist (saved-search) + "Return a copy of SAVED-SEARCH in plist form. + +If saved search is a plist then just return a copy. In other +cases, for backwards compatibility, convert to plist form and +return that." + (if (keywordp (car saved-search)) + (copy-sequence saved-search) + (let ((fields (list :name :query :count-query)) + plist-search) + (dolist (field fields plist-search) + (let ((string (notmuch-saved-search-get saved-search field))) + (when string + (setq plist-search (append plist-search (list field string))))))))) + +(defun notmuch-hello--saved-searches-to-plist (symbol) + "Extract a saved-search variable into plist form. + +The new style saved search is just a plist, but for backwards +compatibility we use this function to extract old style saved +searches so they still work in customize." + (let ((saved-searches (default-value symbol))) + (mapcar #'notmuch-hello-saved-search-to-plist saved-searches))) + +(define-widget 'notmuch-saved-search-plist 'list + "A single saved search property list." + :tag "Saved Search" + :args '((list :inline t + :format "%v" + (group :format "%v" :inline t + (const :format " Name: " :name) + (string :format "%v")) + (group :format "%v" :inline t + (const :format " Query: " :query) + (string :format "%v"))) + (checklist :inline t + :format "%v" + (group :format "%v" :inline t + (const :format "Shortcut key: " :key) + (key-sequence :format "%v")) + (group :format "%v" :inline t + (const :format "Count-Query: " :count-query) + (string :format "%v")) + (group :format "%v" :inline t + (const :format "" :sort-order) + (choice :tag " Sort Order" + (const :tag "Default" nil) + (const :tag "Oldest-first" oldest-first) + (const :tag "Newest-first" newest-first))) + (group :format "%v" :inline t + (const :format "" :excluded) + (choice :tag " Hide Excluded" + (const :tag "Default" nil) + (const :tag "Hide" hide) + (const :tag "Show" show))) + (group :format "%v" :inline t + (const :format "" :search-type) + (choice :tag " Search Type" + (const :tag "Search mode" nil) + (const :tag "Tree mode" tree) + (const :tag "Unthreaded mode" unthreaded)))))) + +(defcustom notmuch-saved-searches + `((:name "inbox" :query "tag:inbox" :key ,(kbd "i")) + (:name "unread" :query "tag:unread" :key ,(kbd "u")) + (:name "flagged" :query "tag:flagged" :key ,(kbd "f")) + (:name "sent" :query "tag:sent" :key ,(kbd "t")) + (:name "drafts" :query "tag:draft" :key ,(kbd "d")) + (:name "all mail" :query "*" :key ,(kbd "a"))) + "A list of saved searches to display. + +The saved search can be given in 3 forms. The preferred way is as +a plist. Supported properties are + + :name Name of the search (required). + :query Search to run (required). + :key Optional shortcut key for `notmuch-jump-search'. + :count-query Optional extra query to generate the count + shown. If not present then the :query property + is used. + :sort-order Specify the sort order to be used for the search. + Possible values are `oldest-first', `newest-first' + or nil. Nil means use the default sort order. + :excluded Whether to show mail with excluded tags in the + search. Possible values are `hide', `show', + or nil. Nil means use the default value of + `notmuch-search-hide-excluded'. + :search-type Specify whether to run the search in search-mode, + tree mode or unthreaded mode. Set to `tree' to + specify tree mode, \\='unthreaded to specify + unthreaded mode, and set to nil (or anything + except tree and unthreaded) to specify search + mode. + +Other accepted forms are a cons cell of the form (NAME . QUERY) +or a list of the form (NAME QUERY COUNT-QUERY)." + ;; The saved-search format is also used by the all-tags notmuch-hello + ;; section. This section generates its own saved-search list in one of + ;; the latter two forms. + :get 'notmuch-hello--saved-searches-to-plist + :type '(repeat notmuch-saved-search-plist) + :tag "List of Saved Searches" + :group 'notmuch-hello) + +(defcustom notmuch-hello-recent-searches-max 10 + "The number of recent searches to display." + :type 'integer + :group 'notmuch-hello) + +(defcustom notmuch-show-empty-saved-searches nil + "Should saved searches with no messages be listed?" + :type 'boolean + :group 'notmuch-hello) + +(defun notmuch-sort-saved-searches (saved-searches) + "Generate an alphabetically sorted saved searches list." + (sort (copy-sequence saved-searches) + (lambda (a b) + (string< (notmuch-saved-search-get a :name) + (notmuch-saved-search-get b :name))))) + +(defcustom notmuch-saved-search-sort-function nil + "Function used to sort the saved searches for the notmuch-hello view. + +This variable controls how saved searches should be sorted. No +sorting (nil) displays the saved searches in the order they are +stored in `notmuch-saved-searches'. Sort alphabetically sorts the +saved searches in alphabetical order. Custom sort function should +be a function or a lambda expression that takes the saved +searches list as a parameter, and returns a new saved searches +list to be used. For compatibility with the various saved-search +formats it should use notmuch-saved-search-get to access the +fields of the search." + :type '(choice (const :tag "No sorting" nil) + (const :tag "Sort alphabetically" notmuch-sort-saved-searches) + (function :tag "Custom sort function" + :value notmuch-sort-saved-searches)) + :group 'notmuch-hello) + +(defvar notmuch-hello-indent 4 + "How much to indent non-headers.") + +(defimage notmuch-hello-logo ((:type svg :file "notmuch-logo.svg"))) + +(defcustom notmuch-show-logo t + "Should the notmuch logo be shown?" + :type 'boolean + :group 'notmuch-hello) + +(defcustom notmuch-show-all-tags-list nil + "Should all tags be shown in the notmuch-hello view?" + :type 'boolean + :group 'notmuch-hello) + +(defcustom notmuch-hello-tag-list-make-query nil + "Function or string to generate queries for the all tags list. + +This variable controls which query results are shown for each tag +in the \"all tags\" list. If nil, it will use all messages with +that tag. If this is set to a string, it is used as a filter for +messages having that tag (equivalent to \"tag:TAG and (THIS-VARIABLE)\"). +Finally this can be a function that will be called for each tag and +should return a filter for that tag, or nil to hide the tag." + :type '(choice (const :tag "All messages" nil) + (const :tag "Unread messages" "tag:unread") + (string :tag "Custom filter" + :value "tag:unread") + (function :tag "Custom filter function")) + :group 'notmuch-hello) + +(defcustom notmuch-hello-hide-tags nil + "List of tags to be hidden in the \"all tags\"-section." + :type '(repeat string) + :group 'notmuch-hello) + +(defface notmuch-hello-logo-background + '((((class color) + (background dark)) + (:background "#5f5f5f")) + (((class color) + (background light)) + (:background "white"))) + "Background colour for the notmuch logo." + :group 'notmuch-hello + :group 'notmuch-faces) + +(defcustom notmuch-column-control t + "Controls the number of columns for saved searches/tags in notmuch view. + +This variable has three potential sets of values: + +- t: automatically calculate the number of columns possible based + on the tags to be shown and the window width, +- an integer: a lower bound on the number of characters that will + be used to display each column, +- a float: a fraction of the window width that is the lower bound + on the number of characters that should be used for each + column. + +So: +- if you would like two columns of tags, set this to 0.5. +- if you would like a single column of tags, set this to 1.0. +- if you would like tags to be 30 characters wide, set this to + 30. +- if you don't want to worry about all of this nonsense, leave + this set to `t'." + :type '(choice + (const :tag "Automatically calculated" t) + (integer :tag "Number of characters") + (float :tag "Fraction of window")) + :group 'notmuch-hello) + +(defcustom notmuch-hello-thousands-separator " " + "The string used as a thousands separator. + +Typically \",\" in the US and UK and \".\" or \" \" in Europe. +The latter is recommended in the SI/ISO 31-0 standard and by the +International Bureau of Weights and Measures." + :type 'string + :group 'notmuch-hello) + +(defcustom notmuch-hello-mode-hook nil + "Functions called after entering `notmuch-hello-mode'." + :type 'hook + :group 'notmuch-hello + :group 'notmuch-hooks) + +(defcustom notmuch-hello-refresh-hook nil + "Functions called after updating a `notmuch-hello' buffer." + :type 'hook + :group 'notmuch-hello + :group 'notmuch-hooks) + +(defconst notmuch-hello-url "https://notmuchmail.org" + "The `notmuch' web site.") + +(defvar notmuch-hello-custom-section-options + '((:filter (string :tag "Filter for each tag")) + (:filter-count (string :tag "Different filter to generate message counts")) + (:initially-hidden (const :tag "Hide this section on startup" t)) + (:show-empty-searches (const :tag "Show queries with no matching messages" t)) + (:hide-if-empty (const :tag "Hide this section if all queries are empty +\(and not shown by show-empty-searches)" t))) + "Various customization-options for notmuch-hello-tags/query-section.") + +(define-widget 'notmuch-hello-tags-section 'lazy + "Customize-type for notmuch-hello tag-list sections." + :tag "Customized tag-list section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-tags-section) + (string :tag "Title for this section") + (plist + :inline t + :options + ,(append notmuch-hello-custom-section-options + '((:hide-tags (repeat :tag "Tags that will be hidden" + string))))))) + +(define-widget 'notmuch-hello-query-section 'lazy + "Customize-type for custom saved-search-like sections" + :tag "Customized queries section (see docstring for details)" + :type + `(list :tag "" + (const :tag "" notmuch-hello-insert-searches) + (string :tag "Title for this section") + (repeat :tag "Queries" + (cons (string :tag "Name") (string :tag "Query"))) + (plist :inline t :options ,notmuch-hello-custom-section-options))) + +(defcustom notmuch-hello-sections + (list #'notmuch-hello-insert-header + #'notmuch-hello-insert-saved-searches + #'notmuch-hello-insert-search + #'notmuch-hello-insert-recent-searches + #'notmuch-hello-insert-alltags + #'notmuch-hello-insert-footer) + "Sections for notmuch-hello. + +The list contains functions which are used to construct sections in +notmuch-hello buffer. When notmuch-hello buffer is constructed, +these functions are run in the order they appear in this list. Each +function produces a section simply by adding content to the current +buffer. A section should not end with an empty line, because a +newline will be inserted after each section by `notmuch-hello'. + +Each function should take no arguments. The return value is +ignored. + +For convenience an element can also be a list of the form (FUNC ARG1 +ARG2 .. ARGN) in which case FUNC will be applied to the rest of the +list. + +A \"Customized tag-list section\" item in the customize-interface +displays a list of all tags, optionally hiding some of them. It +is also possible to filter the list of messages matching each tag +by an additional filter query. Similarly, the count of messages +displayed next to the buttons can be generated by applying a +different filter to the tag query. These filters are also +supported for \"Customized queries section\" items." + :group 'notmuch-hello + :type + '(repeat + (choice (function-item notmuch-hello-insert-header) + (function-item notmuch-hello-insert-saved-searches) + (function-item notmuch-hello-insert-search) + (function-item notmuch-hello-insert-recent-searches) + (function-item notmuch-hello-insert-alltags) + (function-item notmuch-hello-insert-footer) + (function-item notmuch-hello-insert-inbox) + notmuch-hello-tags-section + notmuch-hello-query-section + (function :tag "Custom section")))) + +(defcustom notmuch-hello-auto-refresh t + "Automatically refresh when returning to the notmuch-hello buffer." + :group 'notmuch-hello + :type 'boolean) + +;;; Internal variables + +(defvar notmuch-hello-hidden-sections nil + "List of sections titles whose contents are hidden.") + +(defvar notmuch-hello-first-run t + "True if `notmuch-hello' is run for the first time, set to nil afterwards.") + +;;; Widgets for inserters + +(define-widget 'notmuch-search-item 'item + "A recent search." + :format "%v\n" + :value-create 'notmuch-search-item-value-create) + +(defun notmuch-search-item-value-create (widget) + (let ((value (widget-get widget :value))) + (widget-insert (make-string notmuch-hello-indent ?\s)) + (widget-create 'editable-field + :size (widget-get widget :size) + :parent widget + :action #'notmuch-hello-search + value) + (widget-insert " ") + (widget-create 'push-button + :parent widget + :notify #'notmuch-hello-add-saved-search + "save") + (widget-insert " ") + (widget-create 'push-button + :parent widget + :notify #'notmuch-hello-delete-search-from-history + "del"))) + +(defun notmuch-search-item-field-width () + (max 8 ; Don't let the search boxes be less than 8 characters wide. + (- (window-width) + notmuch-hello-indent ; space at bol + notmuch-hello-indent ; space at eol + 1 ; for the space before the [save] button + 6 ; for the [save] button + 1 ; for the space before the [del] button + 5))) ; for the [del] button + +;;; Widget actions + +(defun notmuch-hello-search (widget &rest _event) + (let ((search (widget-value widget))) + (when search + (setq search (string-trim search)) + (let ((history-delete-duplicates t)) + (add-to-history 'notmuch-search-history search))) + (notmuch-search search notmuch-search-oldest-first))) + +(defun notmuch-hello-add-saved-search (widget &rest _event) + (let ((search (widget-value (widget-get widget :parent))) + (name (completing-read "Name for saved search: " + notmuch-saved-searches))) + ;; If an existing saved search with this name exists, remove it. + (setq notmuch-saved-searches + (cl-loop for elem in notmuch-saved-searches + unless (equal name (notmuch-saved-search-get elem :name)) + collect elem)) + ;; Add the new one. + (customize-save-variable 'notmuch-saved-searches + (add-to-list 'notmuch-saved-searches + (list :name name :query search) t)) + (message "Saved '%s' as '%s'." search name) + (notmuch-hello-update))) + +(defun notmuch-hello-delete-search-from-history (widget &rest _event) + (when (y-or-n-p "Are you sure you want to delete this search? ") + (let ((search (widget-value (widget-get widget :parent)))) + (setq notmuch-search-history + (delete search notmuch-search-history))) + (notmuch-hello-update))) + +;;; Button utilities + +;; `notmuch-hello-query-counts', `notmuch-hello-nice-number' and +;; `notmuch-hello-insert-buttons' are used outside this section. +;; All other functions that are defined in this section are only +;; used by these two functions. + +(defun notmuch-hello-longest-label (searches-alist) + (or (cl-loop for elem in searches-alist + maximize (length (notmuch-saved-search-get elem :name))) + 0)) + +(defun notmuch-hello-reflect-generate-row (ncols nrows row list) + (let ((len (length list))) + (cl-loop for col from 0 to (- ncols 1) + collect (let ((offset (+ (* nrows col) row))) + (if (< offset len) + (nth offset list) + ;; Don't forget to insert an empty slot in the + ;; output matrix if there is no corresponding + ;; value in the input matrix. + nil))))) + +(defun notmuch-hello-reflect (list ncols) + "Reflect a `ncols' wide matrix represented by `list' along the +diagonal." + ;; Not very lispy... + (let ((nrows (ceiling (length list) ncols))) + (cl-loop for row from 0 to (- nrows 1) + append (notmuch-hello-reflect-generate-row ncols nrows row list)))) + +(defun notmuch-hello-widget-search (widget &rest _ignore) + (let ((search-terms (widget-get widget :notmuch-search-terms)) + (oldest-first (widget-get widget :notmuch-search-oldest-first)) + (exclude (widget-get widget :notmuch-search-hide-excluded))) + (cl-case (widget-get widget :notmuch-search-type) + (tree + (let ((n (notmuch-search-format-buffer-name (widget-value widget) "tree" t))) + (notmuch-tree search-terms nil nil n nil nil nil oldest-first exclude))) + (unthreaded + (let ((n (notmuch-search-format-buffer-name (widget-value widget) + "unthreaded" t))) + (notmuch-unthreaded search-terms nil nil n nil oldest-first exclude))) + (t + (notmuch-search search-terms oldest-first exclude))))) + +(defun notmuch-saved-search-count (search) + (car (notmuch--process-lines notmuch-command "count" search))) + +(defun notmuch-hello-tags-per-line (widest) + "Determine how many tags to show per line and how wide they +should be. Returns a cons cell `(tags-per-line width)'." + (let ((tags-per-line + (cond + ((integerp notmuch-column-control) + (max 1 + (/ (- (window-width) notmuch-hello-indent) + ;; Count is 9 wide (8 digits plus space), 1 for the space + ;; after the name. + (+ 9 1 (max notmuch-column-control widest))))) + ((floatp notmuch-column-control) + (let* ((available-width (- (window-width) notmuch-hello-indent)) + (proposed-width (max (* available-width notmuch-column-control) + widest))) + (floor available-width proposed-width))) + (t + (max 1 + (/ (- (window-width) notmuch-hello-indent) + ;; Count is 9 wide (8 digits plus space), 1 for the space + ;; after the name. + (+ 9 1 widest))))))) + (cons tags-per-line (/ (max 1 + (- (window-width) notmuch-hello-indent + ;; Count is 9 wide (8 digits plus + ;; space), 1 for the space after the + ;; name. + (* tags-per-line (+ 9 1)))) + tags-per-line)))) + +(defun notmuch-hello-filtered-query (query filter) + "Constructs a query to search all messages matching QUERY and FILTER. + +If FILTER is a string, it is directly used in the returned query. + +If FILTER is a function, it is called with QUERY as a parameter and +the string it returns is used as the query. If nil is returned, +the entry is hidden. + +Otherwise, FILTER is ignored." + (cond + ((functionp filter) (funcall filter query)) + ((stringp filter) + (concat "(" query ") and (" filter ")")) + (t query))) + +(defun notmuch-hello-query-counts (query-list &rest options) + "Compute list of counts of matched messages from QUERY-LIST. + +QUERY-LIST must be a list of saved-searches. Ideally each of +these is a plist but other options are available for backwards +compatibility: see `notmuch-saved-searches' for details. + +The result is a list of plists each of which includes the +properties :name NAME, :query QUERY and :count COUNT, together +with any properties in the original saved-search. + +The values :show-empty-searches, :filter and :filter-count from +options will be handled as specified for +`notmuch-hello-insert-searches'. :disable-includes can be used to +turn off the default exclude processing in `notmuch-count(1)'" + (with-temp-buffer + (dolist (elem query-list nil) + (let ((count-query (or (notmuch-saved-search-get elem :count-query) + (notmuch-saved-search-get elem :query)))) + (insert + (replace-regexp-in-string + "\n" " " + (notmuch-hello-filtered-query count-query + (or (plist-get options :filter-count) + (plist-get options :filter)))) + "\n"))) + (unless (= (notmuch--call-process-region (point-min) (point-max) notmuch-command + t t nil "count" + (if (plist-get options :disable-excludes) + "--exclude=false" + "--exclude=true") + "--batch") 0) + (notmuch-logged-error + "notmuch count --batch failed" + "Please check that the notmuch CLI is new enough to support `count +--batch'. In general we recommend running matching versions of +the CLI and emacs interface.")) + (goto-char (point-min)) + (cl-mapcan + (lambda (elem) + (let* ((elem-plist (notmuch-hello-saved-search-to-plist elem)) + (search-query (plist-get elem-plist :query)) + (filtered-query (notmuch-hello-filtered-query + search-query (plist-get options :filter))) + (message-count (prog1 (read (current-buffer)) + (forward-line 1)))) + (when (and filtered-query (or (plist-get options :show-empty-searches) + (> message-count 0))) + (setq elem-plist (plist-put elem-plist :query filtered-query)) + (list (plist-put elem-plist :count message-count))))) + query-list))) + +(defun notmuch-hello-nice-number (n) + (let (result) + (while (> n 0) + (push (% n 1000) result) + (setq n (/ n 1000))) + (setq result (or result '(0))) + (apply #'concat + (number-to-string (car result)) + (mapcar (lambda (elem) + (format "%s%03d" notmuch-hello-thousands-separator elem)) + (cdr result))))) + +(defun notmuch-hello-insert-buttons (searches) + "Insert buttons for SEARCHES. + +SEARCHES must be a list of plists each of which should contain at +least the properties :name NAME :query QUERY and :count COUNT, +where QUERY is the query to start when the button for the +corresponding entry is activated, and COUNT should be the number +of messages matching the query. Such a plist can be computed +with `notmuch-hello-query-counts'." + (let* ((widest (notmuch-hello-longest-label searches)) + (tags-and-width (notmuch-hello-tags-per-line widest)) + (tags-per-line (car tags-and-width)) + (column-width (cdr tags-and-width)) + (column-indent 0) + (count 0) + (reordered-list (notmuch-hello-reflect searches tags-per-line)) + ;; Hack the display of the buttons used. + (widget-push-button-prefix "") + (widget-push-button-suffix "")) + ;; dme: It feels as though there should be a better way to + ;; implement this loop than using an incrementing counter. + (mapc (lambda (elem) + ;; (not elem) indicates an empty slot in the matrix. + (when elem + (when (> column-indent 0) + (widget-insert (make-string column-indent ? ))) + (let* ((name (plist-get elem :name)) + (query (plist-get elem :query)) + (oldest-first (cl-case (plist-get elem :sort-order) + (newest-first nil) + (oldest-first t) + (otherwise notmuch-search-oldest-first))) + (exclude (cl-case (plist-get elem :excluded) + (hide t) + (show nil) + (otherwise notmuch-search-hide-excluded))) + (search-type (plist-get elem :search-type)) + (msg-count (plist-get elem :count))) + (widget-insert (format "%8s " + (notmuch-hello-nice-number msg-count))) + (widget-create 'push-button + :notify #'notmuch-hello-widget-search + :notmuch-search-terms query + :notmuch-search-oldest-first oldest-first + :notmuch-search-type search-type + :notmuch-search-hide-excluded exclude + name) + (setq column-indent + (1+ (max 0 (- column-width (length name))))))) + (cl-incf count) + (when (eq (% count tags-per-line) 0) + (setq column-indent 0) + (widget-insert "\n"))) + reordered-list) + ;; If the last line was not full (and hence did not include a + ;; carriage return), insert one now. + (unless (eq (% count tags-per-line) 0) + (widget-insert "\n")))) + +;;; Mode + +(defun notmuch-hello-update () + "Update the notmuch-hello buffer." + ;; Lazy - rebuild everything. + (interactive) + (notmuch-hello t)) + +(defun notmuch-hello-window-configuration-change () + "Hook function to update the hello buffer when it is switched to." + (let ((hello-buf (get-buffer "*notmuch-hello*")) + (do-refresh nil)) + ;; Consider all windows in the currently selected frame, since + ;; that's where the configuration change happened. This also + ;; refreshes our snapshot of all windows, so we have to do this + ;; even if we know we won't refresh (e.g., hello-buf is null). + (dolist (window (window-list)) + (let ((last-buf (window-parameter window 'notmuch-hello-last-buffer)) + (cur-buf (window-buffer window))) + (unless (eq last-buf cur-buf) + ;; This window changed or is new. Update recorded buffer + ;; for next time. + (set-window-parameter window 'notmuch-hello-last-buffer cur-buf) + (when (and (eq cur-buf hello-buf) last-buf) + ;; The user just switched to hello in this window (hello + ;; is currently visible, was not visible on the last + ;; configuration change, and this is not a new window) + (setq do-refresh t))))) + (when (and do-refresh notmuch-hello-auto-refresh) + (notmuch-hello t)) + (unless hello-buf + ;; Clean up hook + (remove-hook 'window-configuration-change-hook + #'notmuch-hello-window-configuration-change)))) + +(defvar notmuch-hello-mode-map + ;; Inherit both widget-keymap and notmuch-common-keymap. We have + ;; to use make-sparse-keymap to force this to be a new keymap (so + ;; that when we modify map it does not modify widget-keymap). + (let ((map (make-composed-keymap (list (make-sparse-keymap) widget-keymap)))) + (set-keymap-parent map notmuch-common-keymap) + ;; Currently notmuch-hello-mode supports free text entry, but not + ;; tagging operations, so provide standard undo. + (define-key map [remap notmuch-tag-undo] #'undo) + map) + "Keymap for \"notmuch hello\" buffers.") + +(define-derived-mode notmuch-hello-mode fundamental-mode "notmuch-hello" + "Major mode for convenient notmuch navigation. This is your entry +portal into notmuch. + +Saved searches are \"bookmarks\" for arbitrary queries. Hit RET +or click on a saved search to view matching threads. Edit saved +searches with the `edit' button. Type `\\[notmuch-jump-search]' +in any Notmuch screen for quick access to saved searches that +have shortcut keys. + +Type new searches in the search box and hit RET to view matching +threads. Hit RET in a recent search box to re-submit a previous +search. Edit it first if you like. Save a recent search to saved +searches with the `save' button. + +Hit `\\[notmuch-search]' or `\\[notmuch-tree]' in any Notmuch +screen to search for messages and view matching threads or +messages, respectively. Recent searches are available in the +minibuffer history. + +Expand the all tags view with the `show' button (and collapse +again with the `hide' button). Hit RET or click on a tag name to +view matching threads. + +Hit `\\[notmuch-refresh-this-buffer]' to refresh the screen and +`\\[notmuch-bury-or-kill-this-buffer]' to quit. + +The screen may be customized via `\\[customize]'. + +Complete list of currently available key bindings: + +\\{notmuch-hello-mode-map}" + (setq notmuch-buffer-refresh-function #'notmuch-hello-update) + (when (boundp 'untrusted-content) + (setq untrusted-content t))) + +;;; Inserters + +(defun notmuch-hello-generate-tag-alist (&optional hide-tags) + "Return an alist from tags to queries to display in the all-tags section." + (cl-mapcan (lambda (tag) + (and (not (member tag hide-tags)) + (list (cons tag + (concat "tag:" + (notmuch-escape-boolean-term tag)))))) + (notmuch--process-lines notmuch-command "search" "--output=tags" "*"))) + +(defun notmuch-hello-insert-header () + "Insert the default notmuch-hello header." + (when notmuch-show-logo + (let ((image notmuch-hello-logo)) + ;; The notmuch logo uses transparency. That can display poorly + ;; when inserting the image into an emacs buffer (black logo on + ;; a black background), so force the background colour of the + ;; image. We use a face to represent the colour so that + ;; `defface' can be used to declare the different possible + ;; colours, which depend on whether the frame has a light or + ;; dark background. + (setq image (cons 'image + (append (cdr image) + (list :background + (face-background + 'notmuch-hello-logo-background))))) + (insert-image image)) + (widget-insert " ")) + + (widget-insert "Welcome to ") + ;; Hack the display of the links used. + (let ((widget-link-prefix "") + (widget-link-suffix "")) + (widget-create 'link + :notify (lambda (&rest _ignore) + (browse-url notmuch-hello-url)) + :help-echo "Visit the notmuch website." + "notmuch") + (widget-insert ". ") + (widget-insert "You have ") + (widget-create 'link + :notify (lambda (&rest _ignore) + (notmuch-hello-update)) + :help-echo "Refresh" + (notmuch-hello-nice-number + (string-to-number + (car (notmuch--process-lines notmuch-command "count" "--exclude=false"))))) + (widget-insert " messages.\n"))) + +(defun notmuch-hello-insert-saved-searches () + "Insert the saved-searches section." + (let ((searches (notmuch-hello-query-counts + (if notmuch-saved-search-sort-function + (funcall notmuch-saved-search-sort-function + notmuch-saved-searches) + notmuch-saved-searches) + :show-empty-searches notmuch-show-empty-saved-searches))) + (when searches + (widget-insert "Saved searches: ") + (widget-create 'push-button + :notify (lambda (&rest _ignore) + (customize-variable 'notmuch-saved-searches)) + "edit") + (widget-insert "\n\n") + (let ((start (point))) + (notmuch-hello-insert-buttons searches) + (indent-rigidly start (point) notmuch-hello-indent))))) + +(defun notmuch-hello-insert-search () + "Insert a search widget." + (widget-insert "Search: ") + (widget-create 'editable-field + ;; Leave some space at the start and end of the + ;; search boxes. + :size (max 8 (- (window-width) notmuch-hello-indent + (length "Search: "))) + :action #'notmuch-hello-search) + ;; Add an invisible dot to make `widget-end-of-line' ignore + ;; trailing spaces in the search widget field. A dot is used + ;; instead of a space to make `show-trailing-whitespace' + ;; happy, i.e. avoid it marking the whole line as trailing + ;; spaces. + (widget-insert (propertize "." 'invisible t)) + (widget-insert "\n")) + +(defun notmuch-hello-insert-recent-searches () + "Insert recent searches." + (when notmuch-search-history + (widget-insert "Recent searches: ") + (widget-create + 'push-button + :notify (lambda (&rest _ignore) + (when (y-or-n-p "Are you sure you want to clear the searches? ") + (setq notmuch-search-history nil) + (notmuch-hello-update))) + "clear") + (widget-insert "\n\n") + (let ((width (notmuch-search-item-field-width))) + (dolist (search (seq-take notmuch-search-history + notmuch-hello-recent-searches-max)) + (widget-create 'notmuch-search-item :value search :size width))))) + +(defun notmuch-hello-insert-searches (title query-list &rest options) + "Insert a section with TITLE showing a list of buttons made from +QUERY-LIST. + +QUERY-LIST should ideally be a plist but for backwards +compatibility other forms are also accepted (see +`notmuch-saved-searches' for details). The plist should +contain keys :name and :query; if :count-query is also present +then it specifies an alternate query to be used to generate the +count for the associated search. + +Supports the following entries in OPTIONS as a plist: +:initially-hidden - if non-nil, section will be hidden on startup +:show-empty-searches - show buttons with no matching messages +:hide-if-empty - hide if no buttons would be shown + (only makes sense without :show-empty-searches) +:filter - This can be a function that takes the search query as + its argument and returns a filter to be used in conjunction + with the query for that search or nil to hide the + element. This can also be a string that is used as a combined + with each query using \"and\". +:filter-count - Separate filter to generate the count displayed + each search. Accepts the same values as :filter. If :filter + and :filter-count are specified, this will be used instead of + :filter, not in conjunction with it." + + (widget-insert title ": ") + (when (and notmuch-hello-first-run (plist-get options :initially-hidden)) + (add-to-list 'notmuch-hello-hidden-sections title)) + (let ((is-hidden (member title notmuch-hello-hidden-sections)) + (start (point))) + (if is-hidden + (widget-create 'push-button + :notify (lambda (&rest _ignore) + (setq notmuch-hello-hidden-sections + (delete title notmuch-hello-hidden-sections)) + (notmuch-hello-update)) + "show") + (widget-create 'push-button + :notify (lambda (&rest _ignore) + (add-to-list 'notmuch-hello-hidden-sections + title) + (notmuch-hello-update)) + "hide")) + (widget-insert "\n") + (unless is-hidden + (let ((searches (apply 'notmuch-hello-query-counts query-list options))) + (when (or (not (plist-get options :hide-if-empty)) + searches) + (widget-insert "\n") + (notmuch-hello-insert-buttons searches) + (indent-rigidly start (point) notmuch-hello-indent)))))) + +(defun notmuch-hello-insert-tags-section (&optional title &rest options) + "Insert a section displaying all tags with message counts. + +TITLE defaults to \"All tags\". +Allowed options are those accepted by `notmuch-hello-insert-searches' and the +following: + +:hide-tags - List of tags that should be excluded." + (apply 'notmuch-hello-insert-searches + (or title "All tags") + (notmuch-hello-generate-tag-alist (plist-get options :hide-tags)) + options)) + +(defun notmuch-hello-insert-inbox () + "Show an entry for each saved search and inboxed messages for each tag." + (notmuch-hello-insert-searches "What's in your inbox" + (append + notmuch-saved-searches + (notmuch-hello-generate-tag-alist)) + :filter "tag:inbox")) + +(defun notmuch-hello-insert-alltags () + "Insert a section displaying all tags and associated message counts." + (notmuch-hello-insert-tags-section + nil + :initially-hidden (not notmuch-show-all-tags-list) + :hide-tags notmuch-hello-hide-tags + :filter notmuch-hello-tag-list-make-query + :disable-excludes t)) + +(defun notmuch-hello-insert-footer () + "Insert the notmuch-hello footer." + (let ((start (point))) + (widget-insert "Hit `?' for context-sensitive help in any Notmuch screen.\n") + (widget-insert "Customize ") + (widget-create 'link + :notify (lambda (&rest _ignore) + (customize-group 'notmuch)) + :button-prefix "" :button-suffix "" + "Notmuch") + (widget-insert " or ") + (widget-create 'link + :notify (lambda (&rest _ignore) + (customize-variable 'notmuch-hello-sections)) + :button-prefix "" :button-suffix "" + "this page.") + (let ((fill-column (- (window-width) notmuch-hello-indent))) + (center-region start (point))))) + +;;; Hello! + +;;;###autoload +(defun notmuch-hello (&optional no-display) + "Run notmuch and display saved searches, known tags, etc." + (interactive) + (notmuch-assert-cli-sane) + ;; This may cause a window configuration change, so if the + ;; auto-refresh hook is already installed, avoid recursive refresh. + (let ((notmuch-hello-auto-refresh nil)) + (if no-display + (set-buffer "*notmuch-hello*") + (pop-to-buffer-same-window "*notmuch-hello*"))) + ;; Install auto-refresh hook + (when notmuch-hello-auto-refresh + (add-hook 'window-configuration-change-hook + #'notmuch-hello-window-configuration-change)) + (let ((target-line (line-number-at-pos)) + (target-column (current-column)) + (inhibit-read-only t)) + ;; Delete all editable widget fields. Editable widget fields are + ;; tracked in a buffer local variable `widget-field-list' (and + ;; others). If we do `erase-buffer' without properly deleting the + ;; widgets, some widget-related functions are confused later. + (mapc 'widget-delete widget-field-list) + (erase-buffer) + (unless (eq major-mode 'notmuch-hello-mode) + (notmuch-hello-mode)) + (let ((all (overlay-lists))) + ;; Delete all the overlays. + (mapc 'delete-overlay (car all)) + (mapc 'delete-overlay (cdr all))) + (mapc + (lambda (section) + (let ((point-before (point))) + (if (functionp section) + (funcall section) + (apply (car section) (cdr section))) + ;; don't insert a newline when the previous section didn't + ;; show anything. + (unless (eq (point) point-before) + (widget-insert "\n")))) + notmuch-hello-sections) + (widget-setup) + ;; Move point back to where it was before refresh. Use line and + ;; column instead of point directly to be insensitive to additions + ;; and removals of text within earlier lines. + (goto-char (point-min)) + (forward-line (1- target-line)) + (move-to-column target-column)) + (run-hooks 'notmuch-hello-refresh-hook) + (setq notmuch-hello-first-run nil)) + +;;; _ + +(provide 'notmuch-hello) + +;;; notmuch-hello.el ends here blob - /dev/null blob + 3161ed9526d52d5b8de9a9d08eb3bef626eb38ec (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-jump.el @@ -0,0 +1,216 @@ +;;; notmuch-jump.el --- User-friendly shortcut keys -*- lexical-binding: t -*- +;; +;; Copyright © Austin Clements +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Austin Clements +;; David Edmondson + +;;; Code: + +(require 'notmuch-lib) +(require 'notmuch-hello) + +(declare-function notmuch-search "notmuch") +(declare-function notmuch-tree "notmuch-tree") +(declare-function notmuch-unthreaded "notmuch-tree") + +;;;###autoload +(defun notmuch-jump-search () + "Jump to a saved search by shortcut key. + +This prompts for and performs a saved search using the shortcut +keys configured in the :key property of `notmuch-saved-searches'. +Typically these shortcuts are a single key long, so this is a +fast way to jump to a saved search from anywhere in Notmuch." + (interactive) + ;; Build the action map + (let (action-map) + (dolist (saved-search notmuch-saved-searches) + (let* ((saved-search (notmuch-hello-saved-search-to-plist saved-search)) + (key (plist-get saved-search :key))) + (when key + (let ((name (plist-get saved-search :name)) + (query (plist-get saved-search :query)) + (oldest-first + (cl-case (plist-get saved-search :sort-order) + (newest-first nil) + (oldest-first t) + (otherwise (default-value 'notmuch-search-oldest-first)))) + (exclude (cl-case (plist-get saved-search :excluded) + (hide t) + (show nil) + (otherwise notmuch-search-hide-excluded)))) + (push (list key name + (cond + ((eq (plist-get saved-search :search-type) 'tree) + (lambda () (notmuch-tree query nil nil nil nil nil nil + oldest-first exclude))) + ((eq (plist-get saved-search :search-type) 'unthreaded) + (lambda () (notmuch-unthreaded query nil nil nil nil + oldest-first exclude))) + (t + (lambda () (notmuch-search query oldest-first exclude))))) + action-map))))) + (setq action-map (nreverse action-map)) + (if action-map + (notmuch-jump action-map "Search: ") + (error "To use notmuch-jump, %s" + "please customize shortcut keys in notmuch-saved-searches.")))) + +(defface notmuch-jump-key + '((t :inherit minibuffer-prompt)) + "Default face used for keys in `notmuch-jump' and related." + :group 'notmuch-faces) + +(defvar notmuch-jump--action nil) + +;;;###autoload +(defun notmuch-jump (action-map prompt) + "Interactively prompt for one of the keys in ACTION-MAP. + +Displays a summary of all bindings in ACTION-MAP in the +minibuffer, reads a key from the minibuffer, and performs the +corresponding action. The prompt can be canceled with C-g or +RET. PROMPT must be a string to use for the prompt. PROMPT +should include a space at the end. + +ACTION-MAP must be a list of triples of the form + (KEY LABEL ACTION) +where KEY is a key binding, LABEL is a string label to display in +the buffer, and ACTION is a nullary function to call. LABEL may +be null, in which case the action will still be bound, but will +not appear in the pop-up buffer." + (let* ((items (notmuch-jump--format-actions action-map)) + ;; Format the table of bindings and the full prompt + (table + (with-temp-buffer + (notmuch-jump--insert-items (window-body-width) items) + (buffer-string))) + (full-prompt + (concat table "\n\n" + (propertize prompt 'face 'minibuffer-prompt))) + ;; By default, the minibuffer applies the minibuffer face to + ;; the entire prompt. However, we want to clearly + ;; distinguish bindings (which we put in the prompt face + ;; ourselves) from their labels, so disable the minibuffer's + ;; own re-face-ing. + (minibuffer-prompt-properties + (notmuch-plist-delete + (copy-sequence minibuffer-prompt-properties) + 'face)) + ;; Build the keymap with our bindings + (minibuffer-map (notmuch-jump--make-keymap action-map prompt)) + ;; The bindings save the the action in notmuch-jump--action + (notmuch-jump--action nil)) + ;; Read the action + (read-from-minibuffer full-prompt nil minibuffer-map) + ;; If we got an action, do it + (when notmuch-jump--action + (funcall notmuch-jump--action)))) + +(defun notmuch-jump--format-actions (action-map) + "Format the actions in ACTION-MAP. + +Returns a list of strings, one for each item with a label in +ACTION-MAP. These strings can be inserted into a tabular +buffer." + ;; Compute the maximum key description width + (let ((key-width 1)) + (pcase-dolist (`(,key ,_desc) action-map) + (setq key-width + (max key-width + (string-width (format-kbd-macro key))))) + ;; Format each action + (mapcar (pcase-lambda (`(,key ,desc)) + (setq key (format-kbd-macro key)) + (concat (propertize key 'face 'notmuch-jump-key) + (make-string (- key-width (length key)) ? ) + " " desc)) + action-map))) + +(defun notmuch-jump--insert-items (width items) + "Make a table of ITEMS up to WIDTH wide in the current buffer." + (let* ((nitems (length items)) + (col-width (+ 3 (apply #'max (mapcar #'string-width items)))) + (ncols (if (> (* col-width nitems) width) + (max 1 (/ width col-width)) + ;; Items fit on one line. Space them out + (setq col-width (/ width nitems)) + (length items)))) + (while items + (dotimes (col ncols) + (when items + (let ((item (pop items))) + (insert item) + (when (and items (< col (- ncols 1))) + (insert (make-string (- col-width (string-width item)) ? )))))) + (when items + (insert "\n"))))) + +(defvar notmuch-jump-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + ;; Make this like a special-mode keymap, with no self-insert-command + (suppress-keymap map) + (define-key map (kbd "DEL") 'exit-minibuffer) + map) + "Base keymap for notmuch-jump's minibuffer keymap.") + +(defun notmuch-jump--make-keymap (action-map prompt) + "Translate ACTION-MAP into a minibuffer keymap." + (let ((map (make-sparse-keymap))) + (set-keymap-parent map notmuch-jump-minibuffer-map) + (pcase-dolist (`(,key ,_name ,fn) action-map) + (when (= (length key) 1) + (define-key map key + (lambda () + (interactive) + (setq notmuch-jump--action fn) + (exit-minibuffer))))) + ;; By doing this in two passes (and checking if we already have a + ;; binding) we avoid problems if the user specifies a binding which + ;; is a prefix of another binding. + (pcase-dolist (`(,key ,_name ,_fn) action-map) + (when (> (length key) 1) + (let* ((key (elt key 0)) + (keystr (string key)) + (new-prompt (concat prompt (format-kbd-macro keystr) " ")) + (action-submap nil)) + (unless (lookup-key map keystr) + (pcase-dolist (`(,k ,n ,f) action-map) + (when (= key (elt k 0)) + (push (list (substring k 1) n f) action-submap))) + ;; We deal with backspace specially + (push (list (kbd "DEL") + "Backup" + (apply-partially #'notmuch-jump action-map prompt)) + action-submap) + (setq action-submap (nreverse action-submap)) + (define-key map keystr + (lambda () + (interactive) + (setq notmuch-jump--action + (apply-partially #'notmuch-jump + action-submap + new-prompt)) + (exit-minibuffer))))))) + map)) + +(provide 'notmuch-jump) + +;;; notmuch-jump.el ends here blob - /dev/null blob + bf9c4a534a24f5d5c088857ce420600604259326 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-lib.el @@ -0,0 +1,1085 @@ +;;; notmuch-lib.el --- common variables, functions and function declarations -*- lexical-binding: t -*- +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Carl Worth + +;;; Code: + +(require 'cl-lib) +(require 'pcase) +(require 'subr-x) + +(require 'mm-util) +(require 'mm-view) +(require 'mm-decode) + +(require 'notmuch-compat) + +(unless (require 'notmuch-version nil t) + (defconst notmuch-emacs-version "unknown" + "Placeholder variable when notmuch-version.el[c] is not available.")) + +;;; Groups + +(defgroup notmuch nil + "Notmuch mail reader for Emacs." + :group 'mail) + +(defgroup notmuch-hello nil + "Overview of saved searches, tags, etc." + :group 'notmuch) + +(defgroup notmuch-search nil + "Searching and sorting mail." + :group 'notmuch) + +(defgroup notmuch-show nil + "Showing messages and threads." + :group 'notmuch) + +(defgroup notmuch-send nil + "Sending messages from Notmuch." + :group 'notmuch + :group 'message) + +(defgroup notmuch-tag nil + "Tags and tagging in Notmuch." + :group 'notmuch) + +(defgroup notmuch-crypto nil + "Processing and display of cryptographic MIME parts." + :group 'notmuch) + +(defgroup notmuch-hooks nil + "Running custom code on well-defined occasions." + :group 'notmuch) + +(defgroup notmuch-external nil + "Running external commands from within Notmuch." + :group 'notmuch) + +(defgroup notmuch-address nil + "Address completion." + :group 'notmuch) + +(defgroup notmuch-faces nil + "Graphical attributes for displaying text" + :group 'notmuch) + +;;; Options + +(defcustom notmuch-command "notmuch" + "Name of the notmuch binary. + +This can be a relative or absolute path to the notmuch binary. +If this is a relative path, it will be searched for in all of the +directories given in `exec-path' (which is, by default, based on +$PATH)." + :type 'string + :group 'notmuch-external) + +(defcustom notmuch-search-oldest-first t + "Show the oldest mail first when searching. + +This variable defines the default sort order for displaying +search results. Note that any filtered searches created by +`notmuch-search-filter' retain the search order of the parent +search." + :type 'boolean + :group 'notmuch-search) +(make-variable-buffer-local 'notmuch-search-oldest-first) + +(defcustom notmuch-search-hide-excluded t + "Hide mail tagged with a excluded tag. + +Excluded tags are defined in the users configuration file under +the search section. When this variable is true, any mail with +such a tag will not be shown in the search output." + :type 'boolean + :group 'notmuch-search) +(make-variable-buffer-local 'notmuch-search-hide-excluded) + +(defcustom notmuch-poll-script nil + "[Deprecated] Command to run to incorporate new mail into the notmuch database. + +This option has been deprecated in favor of \"notmuch new\" +hooks (see man notmuch-hooks). To change the path to the notmuch +binary, customize `notmuch-command'. + +This variable controls the action invoked by +`notmuch-poll-and-refresh-this-buffer' (bound by default to 'G') +to incorporate new mail into the notmuch database. + +If set to nil (the default), new mail is processed by invoking +\"notmuch new\". Otherwise, this should be set to a string that +gives the name of an external script that processes new mail. If +set to the empty string, no command will be run. + +The external script could do any of the following depending on +the user's needs: + +1. Invoke a program to transfer mail to the local mail store +2. Invoke \"notmuch new\" to incorporate the new mail +3. Invoke one or more \"notmuch tag\" commands to classify the mail" + :type '(choice (const :tag "notmuch new" nil) + (const :tag "Disabled" "") + (string :tag "Custom script")) + :group 'notmuch-external) + +(defcustom notmuch-archive-tags '("-inbox") + "List of tag changes to apply to a message or a thread when it is archived. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message or thread being archived. + +For example, if you wanted to remove an \"inbox\" tag and add an +\"archived\" tag, you would set: + (\"-inbox\" \"+archived\")" + :type '(repeat string) + :group 'notmuch-search + :group 'notmuch-show) + +;;; Variables + +(defvar notmuch-search-history nil + "Variable to store notmuch searches history.") + +(defvar notmuch-common-keymap + (let ((map (make-sparse-keymap))) + (define-key map "?" 'notmuch-help) + (define-key map "v" 'notmuch-version) + (define-key map "q" 'notmuch-bury-or-kill-this-buffer) + (define-key map "s" 'notmuch-search) + (define-key map "t" 'notmuch-search-by-tag) + (define-key map "z" 'notmuch-tree) + (define-key map "u" 'notmuch-unthreaded) + (define-key map "m" 'notmuch-mua-new-mail) + (define-key map "g" 'notmuch-refresh-this-buffer) + (define-key map "=" 'notmuch-refresh-this-buffer) + (define-key map (kbd "M-=") 'notmuch-refresh-all-buffers) + (define-key map "G" 'notmuch-poll-and-refresh-this-buffer) + (define-key map "j" 'notmuch-jump-search) + (define-key map [remap undo] 'notmuch-tag-undo) + map) + "Keymap shared by all notmuch modes.") + +;; By default clicking on a button does not select the window +;; containing the button (as opposed to clicking on a widget which +;; does). This means that the button action is then executed in the +;; current selected window which can cause problems if the button +;; changes the buffer (e.g., id: links) or moves point. +;; +;; This provides a button type which overrides mouse-action so that +;; the button's window is selected before the action is run. Other +;; notmuch buttons can get the same behaviour by inheriting from this +;; button type. +(define-button-type 'notmuch-button-type + 'mouse-action (lambda (button) + (select-window (posn-window (event-start last-input-event))) + (button-activate button))) + +;;; CLI Utilities + +(defun notmuch-command-to-string (&rest args) + "Synchronously invoke \"notmuch\" with the given list of arguments. + +If notmuch exits with a non-zero status, output from the process +will appear in a buffer named \"*Notmuch errors*\" and an error +will be signaled. + +Otherwise the output will be returned." + (with-temp-buffer + (let ((status (apply #'notmuch--call-process notmuch-command nil t nil args)) + (output (buffer-string))) + (notmuch-check-exit-status status (cons notmuch-command args) output) + output))) + +(defvar notmuch--cli-sane-p nil + "Cache whether the CLI seems to be configured sanely.") + +(defun notmuch-cli-sane-p () + "Return t if the cli seems to be configured sanely." + (unless notmuch--cli-sane-p + (let ((status (notmuch--call-process notmuch-command nil nil nil + "config" "get" "user.primary_email"))) + (setq notmuch--cli-sane-p (= status 0)))) + notmuch--cli-sane-p) + +(defun notmuch-assert-cli-sane () + (unless (notmuch-cli-sane-p) + (notmuch-logged-error + "notmuch cli seems misconfigured or unconfigured." + "Perhaps you haven't run \"notmuch setup\" yet? Try running this +on the command line, and then retry your notmuch command"))) + +(defun notmuch-cli-version () + "Return a string with the notmuch cli command version number." + (let ((long-string + ;; Trim off the trailing newline. + (substring (notmuch-command-to-string "--version") 0 -1))) + (if (string-match "^notmuch\\( version\\)? \\(.*\\)$" + long-string) + (match-string 2 long-string) + "unknown"))) + +(defvar notmuch-emacs-version) + +(defun notmuch-version () + "Display the notmuch version. +The versions of the Emacs package and the `notmuch' executable +should match, but if and only if they don't, then this command +displays both values separately." + (interactive) + (let ((cli-version (notmuch-cli-version))) + (message "notmuch version %s" + (if (string= notmuch-emacs-version cli-version) + cli-version + (concat cli-version + " (emacs mua version " notmuch-emacs-version ")"))))) + +;;; Notmuch Configuration + +(defun notmuch-config-get (item) + "Return a value from the notmuch configuration." + (let* ((val (notmuch-command-to-string "config" "get" item)) + (len (length val))) + ;; Trim off the trailing newline (if the value is empty or not + ;; configured, there will be no newline). + (if (and (> len 0) + (= (aref val (- len 1)) ?\n)) + (substring val 0 -1) + val))) + +(defun notmuch-database-path () + "Return the database.path value from the notmuch configuration." + (notmuch-config-get "database.path")) + +(defun notmuch-user-name () + "Return the user.name value from the notmuch configuration." + (notmuch-config-get "user.name")) + +(defun notmuch-user-primary-email () + "Return the user.primary_email value from the notmuch configuration." + (notmuch-config-get "user.primary_email")) + +(defun notmuch-user-other-email () + "Return the user.other_email value (as a list) from the notmuch configuration." + (split-string (notmuch-config-get "user.other_email") "\n" t)) + +(defun notmuch-user-emails () + (cons (notmuch-user-primary-email) (notmuch-user-other-email))) + +;;; Commands + +(defun notmuch-poll () + "Run \"notmuch new\" or an external script to import mail. + +Invokes `notmuch-poll-script', \"notmuch new\", or does nothing +depending on the value of `notmuch-poll-script'." + (interactive) + (message "Polling mail...") + (if (stringp notmuch-poll-script) + (unless (string-empty-p notmuch-poll-script) + (unless (equal (notmuch--call-process notmuch-poll-script nil nil) 0) + (error "Notmuch: poll script `%s' failed!" notmuch-poll-script))) + (notmuch-call-notmuch-process "new")) + (message "Polling mail...done")) + +(defun notmuch-bury-or-kill-this-buffer () + "Undisplay the current buffer. + +Bury the current buffer, unless there is only one window showing +it, in which case it is killed." + (interactive) + (if (> (length (get-buffer-window-list nil nil t)) 1) + (bury-buffer) + (kill-buffer))) + +;;; Describe Key Bindings + +(defun notmuch-prefix-key-description (key) + "Given a prefix key code, return a human-readable string representation. + +This is basically just `format-kbd-macro' but we also convert ESC to M-." + (let* ((key-vector (if (vectorp key) key (vector key))) + (desc (format-kbd-macro key-vector))) + (if (string= desc "ESC") + "M-" + (concat desc " ")))) + +(defun notmuch-describe-key (actual-key binding prefix ua-keys tail) + "Prepend cons cells describing prefix-arg ACTUAL-KEY and ACTUAL-KEY to TAIL. + +It does not prepend if ACTUAL-KEY is already listed in TAIL." + (let ((key-string (concat prefix (key-description actual-key)))) + ;; We don't include documentation if the key-binding is + ;; over-ridden. Note, over-riding a binding automatically hides the + ;; prefixed version too. + (unless (assoc key-string tail) + (when (and ua-keys (symbolp binding) + (get binding 'notmuch-prefix-doc)) + ;; Documentation for prefixed command + (let ((ua-desc (key-description ua-keys))) + (push (cons (concat ua-desc " " prefix (format-kbd-macro actual-key)) + (get binding 'notmuch-prefix-doc)) + tail))) + ;; Documentation for command + (push (cons key-string + (or (and (symbolp binding) + (get binding 'notmuch-doc)) + (and (functionp binding) + (let ((doc (documentation binding))) + (and doc + (string-match "\\`.+" doc) + (match-string 0 doc)))))) + tail))) + tail) + +(defun notmuch-describe-remaps (remap-keymap ua-keys base-keymap prefix tail) + ;; Remappings are represented as a binding whose first "event" is + ;; 'remap. Hence, if the keymap has any remappings, it will have a + ;; binding whose "key" is 'remap, and whose "binding" is itself a + ;; keymap that maps not from keys to commands, but from old (remapped) + ;; functions to the commands to use in their stead. + (map-keymap (lambda (command binding) + (mapc (lambda (actual-key) + (setq tail + (notmuch-describe-key actual-key binding + prefix ua-keys tail))) + (where-is-internal command base-keymap))) + remap-keymap) + tail) + +(defun notmuch-describe-keymap (keymap ua-keys base-keymap &optional prefix tail) + "Return a list of cons cells, each describing one binding in KEYMAP. + +Each cons cell consists of a string giving a human-readable +description of the key, and a one-line description of the bound +function. See `notmuch-help' for an overview of how this +documentation is extracted. + +UA-KEYS should be a key sequence bound to `universal-argument'. +It will be used to describe bindings of commands that support a +prefix argument. PREFIX and TAIL are used internally." + (map-keymap + (lambda (key binding) + (cond ((mouse-event-p key) nil) + ((keymapp binding) + (setq tail + (if (eq key 'remap) + (notmuch-describe-remaps + binding ua-keys base-keymap prefix tail) + (notmuch-describe-keymap + binding ua-keys base-keymap + (notmuch-prefix-key-description key) + tail)))) + (binding + (setq tail + (notmuch-describe-key (vector key) + binding prefix ua-keys tail))))) + keymap) + tail) + +(defun notmuch-substitute-command-keys (doc) + "Like `substitute-command-keys' but with documentation, not function names." + (let ((beg 0)) + (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg) + (let ((desc + (save-match-data + (let* ((keymap-name (substring doc + (match-beginning 1) + (match-end 1))) + (keymap (symbol-value (intern keymap-name))) + (ua-keys (where-is-internal 'universal-argument keymap t)) + (desc-alist (notmuch-describe-keymap keymap ua-keys keymap)) + (desc-list (mapcar (lambda (arg) + (concat (car arg) "\t" (cdr arg))) + desc-alist))) + (mapconcat #'identity desc-list "\n"))))) + (setq doc (replace-match desc 1 1 doc))) + (setq beg (match-end 0))) + doc)) + +(defun notmuch-help () + "Display help for the current notmuch mode. + +This is similar to `describe-function' for the current major +mode, but bindings tables are shown with documentation strings +rather than command names. By default, this uses the first line +of each command's documentation string. A command can override +this by setting the \\='notmuch-doc property of its command symbol. +A command that supports a prefix argument can explicitly document +its prefixed behavior by setting the \\='notmuch-prefix-doc property +of its command symbol." + (interactive) + (let ((doc (substitute-command-keys + (notmuch-substitute-command-keys + (documentation major-mode t))))) + (with-current-buffer (generate-new-buffer "*notmuch-help*") + (insert doc) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (view-buffer (current-buffer) 'kill-buffer-if-not-modified)))) + +(defun notmuch-subkeymap-help () + "Show help for a subkeymap." + (interactive) + (let* ((key (this-command-keys-vector)) + (prefix (make-vector (1- (length key)) nil)) + (i 0)) + (while (< i (length prefix)) + (aset prefix i (aref key i)) + (cl-incf i)) + (let* ((subkeymap (key-binding prefix)) + (ua-keys (where-is-internal 'universal-argument nil t)) + (prefix-string (notmuch-prefix-key-description prefix)) + (desc-alist (notmuch-describe-keymap + subkeymap ua-keys subkeymap prefix-string)) + (desc-list (mapcar (lambda (arg) (concat (car arg) "\t" (cdr arg))) + desc-alist)) + (desc (mapconcat #'identity desc-list "\n"))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert "\nPress 'q' to quit this window.\n\n") + (insert desc))) + (pop-to-buffer (help-buffer))))) + +;;; Refreshing Buffers + +(defvar-local notmuch-buffer-refresh-function nil + "Function to call to refresh the current buffer.") + +(defun notmuch-refresh-this-buffer () + "Refresh the current buffer." + (interactive) + (when notmuch-buffer-refresh-function + ;; Pass prefix argument, etc. + (call-interactively notmuch-buffer-refresh-function))) + +(defun notmuch-poll-and-refresh-this-buffer () + "Invoke `notmuch-poll' to import mail, then refresh the current buffer." + (interactive) + (notmuch-poll) + (notmuch-refresh-this-buffer)) + +(defun notmuch-refresh-all-buffers () + "Invoke `notmuch-refresh-this-buffer' on all notmuch major-mode buffers. + +The buffers are silently refreshed, i.e. they are not forced to +be displayed." + (interactive) + (dolist (buffer (buffer-list)) + (let ((buffer-mode (buffer-local-value 'major-mode buffer))) + (when (memq buffer-mode '(notmuch-show-mode + notmuch-tree-mode + notmuch-search-mode + notmuch-hello-mode)) + (with-current-buffer buffer + (notmuch-refresh-this-buffer)))))) + +;;; String Utilities + +(defun notmuch-prettify-subject (subject) + ;; This function is used by `notmuch-search-process-filter', + ;; which requires that we not disrupt its matching state. + (save-match-data + (if (and subject + (string-match "^[ \t]*$" subject)) + "[No Subject]" + subject))) + +(defun notmuch-sanitize (str) + "Sanitize control character in STR. + +This includes newlines, tabs, and other funny characters." + (replace-regexp-in-string "[[:cntrl:]\x7f\u2028\u2029]+" " " str)) + +(defun notmuch-escape-boolean-term (term) + "Escape a boolean term for use in a query. + +The caller is responsible for prepending the term prefix and a +colon. This performs minimal escaping in order to produce +user-friendly queries." + (save-match-data + (if (or (equal term "") + ;; To be pessimistic, only pass through terms composed + ;; entirely of ASCII printing characters other than ", (, + ;; and ). + (string-match "[^!#-'*-~]" term)) + ;; Requires escaping + (concat "\"" (replace-regexp-in-string "\"" "\"\"" term t t) "\"") + term))) + +(defun notmuch-id-to-query (id) + "Return a query that matches the message with id ID." + (concat "id:" (notmuch-escape-boolean-term id))) + +(defun notmuch-hex-encode (str) + "Hex-encode STR (e.g., as used by batch tagging). + +This replaces spaces, percents, and double quotes in STR with +%NN where NN is the hexadecimal value of the character." + (replace-regexp-in-string + "[ %\"]" (lambda (match) (format "%%%02x" (aref match 0))) str)) + +(defun notmuch-common-do-stash (text) + "Common function to stash text in kill ring, and display in minibuffer." + (if text + (progn + (kill-new text) + (message "Stashed: %s" text)) + ;; There is nothing to stash so stash an empty string so the user + ;; doesn't accidentally paste something else somewhere. + (kill-new "") + (message "Nothing to stash!"))) + +;;; Generic Utilities + +(defun notmuch-plist-delete (plist property) + (let (p) + (while plist + (unless (eq property (car plist)) + (setq p (plist-put p (car plist) (cadr plist)))) + (setq plist (cddr plist))) + p)) + +;;; MML Utilities + +(defun notmuch-match-content-type (t1 t2) + "Return t if t1 and t2 are matching content types. +Take wildcards into account." + (and (stringp t1) + (stringp t2) + (let ((st1 (split-string t1 "/")) + (st2 (split-string t2 "/"))) + (if (or (string= (cadr st1) "*") + (string= (cadr st2) "*")) + ;; Comparison of content types should be case insensitive. + (string= (downcase (car st1)) + (downcase (car st2))) + (string= (downcase t1) + (downcase t2)))))) + +(defcustom notmuch-multipart/alternative-discouraged + '(;; Avoid HTML parts. + "text/html" + ;; multipart/related usually contain a text/html part and some + ;; associated graphics. + "multipart/related") + "Which mime types to hide by default for multipart messages. + +Can either be a list of mime types (as strings) or a function +mapping a plist representing the current message to such a list. +See Info node `(notmuch-emacs) notmuch-show' for a sample function." + :group 'notmuch-show + :type '(radio (repeat :tag "MIME Types" string) + (function :tag "Function"))) + +(defun notmuch-multipart/alternative-determine-discouraged (msg) + "Return the discouraged alternatives for the specified message." + ;; If a function, return the result of calling it. + (if (functionp notmuch-multipart/alternative-discouraged) + (funcall notmuch-multipart/alternative-discouraged msg) + ;; Otherwise simply return the value of the variable, which is + ;; assumed to be a list of discouraged alternatives. This is the + ;; default behaviour. + notmuch-multipart/alternative-discouraged)) + +(defun notmuch-multipart/alternative-choose (msg types) + "Return a list of preferred types from the given list of types +for this message, if present." + ;; Based on `mm-preferred-alternative-precedence'. + (let ((discouraged (notmuch-multipart/alternative-determine-discouraged msg)) + (seq types)) + (dolist (pref (reverse discouraged)) + (dolist (elem (copy-sequence seq)) + (when (string-match pref elem) + (setq seq (nconc (delete elem seq) (list elem)))))) + seq)) + +(defun notmuch-parts-filter-by-type (parts type) + "Given a list of message parts, return a list containing the ones matching +the given type." + (cl-remove-if-not + (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type)) + parts)) + +(defun notmuch--get-bodypart-raw (msg part process-crypto binaryp cache) + (let* ((plist-elem (if binaryp :content-binary :content)) + (data (or (plist-get part plist-elem) + (with-temp-buffer + ;; Emacs internally uses a UTF-8-like multibyte string + ;; representation by default (regardless of the coding + ;; system, which only affects how it goes from outside data + ;; to this internal representation). This *almost* never + ;; matters. Annoyingly, it does matter if we use this data + ;; in an image descriptor, since Emacs will use its internal + ;; data buffer directly and this multibyte representation + ;; corrupts binary image formats. Since the caller is + ;; asking for binary data, a unibyte string is a more + ;; appropriate representation anyway. + (when binaryp + (set-buffer-multibyte nil)) + (let ((args `("show" "--format=raw" + ,(format "--part=%s" (plist-get part :id)) + ,@(and process-crypto '("--decrypt=true")) + ,(notmuch-id-to-query (plist-get msg :id)))) + (coding-system-for-read + (if binaryp + 'no-conversion + (let ((coding-system + (mm-charset-to-coding-system + (plist-get part :content-charset)))) + ;; Sadly, + ;; `mm-charset-to-coding-system' seems + ;; to return things that are not + ;; considered acceptable values for + ;; `coding-system-for-read'. + (if (coding-system-p coding-system) + coding-system + ;; RFC 2047 says that the default + ;; charset is US-ASCII. RFC6657 + ;; complicates this somewhat. + 'us-ascii))))) + (apply #'notmuch--call-process + notmuch-command nil '(t nil) nil args) + (buffer-string)))))) + (when (and cache data) + (plist-put part plist-elem data)) + data)) + +(defun notmuch-get-bodypart-binary (msg part process-crypto &optional cache) + "Return the unprocessed content of PART in MSG as a unibyte string. + +This returns the \"raw\" content of the given part after content +transfer decoding, but with no further processing (see the +discussion of --format=raw in man notmuch-show). In particular, +this does no charset conversion. + +If CACHE is non-nil, the content of this part will be saved in +MSG (if it isn't already)." + (notmuch--get-bodypart-raw msg part process-crypto t cache)) + +(defun notmuch-get-bodypart-text (msg part process-crypto &optional cache) + "Return the text content of PART in MSG. + +This returns the content of the given part as a multibyte Lisp +string after performing content transfer decoding and any +necessary charset decoding. + +If CACHE is non-nil, the content of this part will be saved in +MSG (if it isn't already)." + (notmuch--get-bodypart-raw msg part process-crypto nil cache)) + +(defun notmuch-mm-display-part-inline (msg part content-type process-crypto) + "Use the mm-decode/mm-view functions to display a part in the +current buffer, if possible." + (let ((display-buffer (current-buffer))) + (with-temp-buffer + ;; In case we already have :content, use it and tell mm-* that + ;; it's already been charset-decoded by using the fake + ;; `gnus-decoded' charset. Otherwise, we'll fetch the binary + ;; part content and let mm-* decode it. + (let* ((have-content (plist-member part :content)) + (charset (if have-content + 'gnus-decoded + (plist-get part :content-charset))) + (handle (mm-make-handle (current-buffer) + `(,content-type (charset . ,charset))))) + ;; If the user wants the part inlined, insert the content and + ;; test whether we are able to inline it (which includes both + ;; capability and suitability tests). + (when (mm-inlined-p handle) + (if have-content + (insert (notmuch-get-bodypart-text msg part process-crypto)) + (insert (notmuch-get-bodypart-binary msg part process-crypto))) + (when (mm-inlinable-p handle) + (set-buffer display-buffer) + (mm-display-part handle) + (plist-put part :undisplayer (mm-handle-undisplayer handle)) + t)))))) + +;;; Generic Utilities + +;; Converts a plist of headers to an alist of headers. The input plist should +;; have symbols of the form :Header as keys, and the resulting alist will have +;; symbols of the form 'Header as keys. +(defun notmuch-headers-plist-to-alist (plist) + (cl-loop for (key value . rest) on plist by #'cddr + collect (cons (intern (substring (symbol-name key) 1)) value))) + +(defun notmuch-face-ensure-list-form (face) + "Return FACE in face list form. + +If FACE is already a face list, it will be returned as-is. If +FACE is a face name or face plist, it will be returned as a +single element face list." + (if (and (listp face) (not (keywordp (car face)))) + face + (list face))) + +(defun notmuch-apply-face (object face &optional below start end) + "Combine FACE into the \\='face text property of OBJECT between START and END. + +This function combines FACE with any existing faces between START +and END in OBJECT. Attributes specified by FACE take precedence +over existing attributes unless BELOW is non-nil. + +OBJECT may be a string, a buffer, or nil (which means the current +buffer). If object is a string, START and END are 0-based; +otherwise they are buffer positions (integers or markers). FACE +must be a face name (a symbol or string), a property list of face +attributes, or a list of these. If START and/or END are omitted, +they default to the beginning/end of OBJECT. For convenience +when applied to strings, this returns OBJECT." + ;; A face property can have three forms: a face name (a string or + ;; symbol), a property list, or a list of these two forms. In the + ;; list case, the faces will be combined, with the earlier faces + ;; taking precedent. Here we canonicalize everything to list form + ;; to make it easy to combine. + (let ((pos (cond (start start) + ((stringp object) 0) + (t 1))) + (end (cond (end end) + ((stringp object) (length object)) + (t (1+ (buffer-size object))))) + (face-list (notmuch-face-ensure-list-form face))) + (while (< pos end) + (let* ((cur (get-text-property pos 'face object)) + (cur-list (notmuch-face-ensure-list-form cur)) + (new (cond ((null cur-list) face) + (below (append cur-list face-list)) + (t (append face-list cur-list)))) + (next (next-single-property-change pos 'face object end))) + (put-text-property pos next 'face new object) + (setq pos next)))) + object) + +(defun notmuch-map-text-property (start end prop func &optional object) + "Transform text property PROP using FUNC. + +Applies FUNC to each distinct value of the text property PROP +between START and END of OBJECT, setting PROP to the value +returned by FUNC." + (while (< start end) + (let ((value (get-text-property start prop object)) + (next (next-single-property-change start prop object end))) + (put-text-property start next prop (funcall func value) object) + (setq start next)))) + +;;; Running Notmuch + +(defun notmuch-logged-error (msg &optional extra) + "Log MSG and EXTRA to *Notmuch errors* and signal MSG. + +This logs MSG and EXTRA to the *Notmuch errors* buffer and +signals MSG as an error. If EXTRA is non-nil, text referring the +user to the *Notmuch errors* buffer will be appended to the +signaled error. This function does not return." + (with-current-buffer (get-buffer-create "*Notmuch errors*") + (goto-char (point-max)) + (unless (bobp) + (newline)) + (save-excursion + (insert "[" (current-time-string) "]\n" msg) + (unless (bolp) + (newline)) + (when extra + (insert extra) + (unless (bolp) + (newline))))) + (error "%s%s" msg (if extra " (see *Notmuch errors* for more details)" ""))) + +(defun notmuch-check-async-exit-status (proc msg &optional command err) + "If PROC exited abnormally, pop up an error buffer and signal an error. + +This is a wrapper around `notmuch-check-exit-status' for +asynchronous process sentinels. PROC and MSG must be the +arguments passed to the sentinel. COMMAND and ERR, if provided, +are passed to `notmuch-check-exit-status'. If COMMAND is not +provided, it is taken from `process-command'." + (let ((exit-status + (cl-case (process-status proc) + ((exit) (process-exit-status proc)) + ((signal) msg)))) + (when exit-status + (notmuch-check-exit-status exit-status + (or command (process-command proc)) + nil err)))) + +(defun notmuch-check-exit-status (exit-status command &optional output err) + "If EXIT-STATUS is non-zero, pop up an error buffer and signal an error. + +If EXIT-STATUS is non-zero, pop up a notmuch error buffer +describing the error and signal an Elisp error. EXIT-STATUS must +be a number indicating the exit status code of a process or a +string describing the signal that terminated the process (such as +returned by `call-process'). COMMAND must be a list giving the +command and its arguments. OUTPUT, if provided, is a string +giving the output of command. ERR, if provided, is the error +output of command. OUTPUT and ERR will be included in the error +message." + (cond + ((eq exit-status 0) t) + ((eq exit-status 20) + (notmuch-logged-error "notmuch CLI version mismatch +Emacs requested an older output format than supported by the notmuch CLI. +You may need to restart Emacs or upgrade your notmuch Emacs package.")) + ((eq exit-status 21) + (notmuch-logged-error "notmuch CLI version mismatch +Emacs requested a newer output format than supported by the notmuch CLI. +You may need to restart Emacs or upgrade your notmuch package.")) + (t + (pcase-let* + ((`(,command . ,args) command) + (command (if (equal (file-name-nondirectory command) + notmuch-command) + notmuch-command + command)) + (command-string + (mapconcat (lambda (arg) + (shell-quote-argument + (cond ((stringp arg) arg) + ((symbolp arg) (symbol-name arg)) + (t "*UNKNOWN ARGUMENT*")))) + (cons command args) + " ")) + (extra + (concat "command: " command-string "\n" + (if (integerp exit-status) + (format "exit status: %s\n" exit-status) + (format "exit signal: %s\n" exit-status)) + (and err (concat "stderr:\n" err)) + (and output (concat "stdout:\n" output))))) + (if err + ;; We have an error message straight from the CLI. + (notmuch-logged-error + (replace-regexp-in-string "[ \n\r\t\f]*\\'" "" err) extra) + ;; We only have combined output from the CLI; don't inundate + ;; the user with it. Mimic `process-lines'. + (notmuch-logged-error (format "%s exited with status %s" + command exit-status) + extra)) + ;; `notmuch-logged-error' does not return. + )))) + +(defmacro notmuch--apply-with-env (func &rest args) + `(let ((default-directory "~")) + (apply ,func ,@args))) + +(defun notmuch--process-lines (program &rest args) + "Wrap process-lines, binding DEFAULT-DIRECTORY to a safe +default" + (notmuch--apply-with-env #'process-lines program args)) + +(defun notmuch--make-process (&rest args) + "Wrap make-process, binding DEFAULT-DIRECTORY to a safe +default" + (notmuch--apply-with-env #'make-process args)) + +(defun notmuch--call-process-region (start end program + &optional delete buffer display + &rest args) + "Wrap call-process-region, binding DEFAULT-DIRECTORY to a safe +default" + (notmuch--apply-with-env + #'call-process-region start end program delete buffer display args)) + +(defun notmuch--call-process (program &optional infile destination display &rest args) + "Wrap call-process, binding DEFAULT-DIRECTORY to a safe default" + (notmuch--apply-with-env #'call-process program infile destination display args)) + +(defun notmuch-call-notmuch--helper (destination args) + "Helper for synchronous notmuch invocation commands. + +This wraps `call-process'. DESTINATION has the same meaning as +for `call-process'. ARGS is as described for +`notmuch-call-notmuch-process'." + (let (stdin-string) + (while (keywordp (car args)) + (cl-case (car args) + (:stdin-string (setq stdin-string (cadr args)) + (setq args (cddr args))) + (otherwise + (error "Unknown keyword argument: %s" (car args))))) + (if (null stdin-string) + (apply #'notmuch--call-process notmuch-command nil destination nil args) + (insert stdin-string) + (apply #'notmuch--call-process-region (point-min) (point-max) + notmuch-command t destination nil args)))) + +(defun notmuch-call-notmuch-process (&rest args) + "Synchronously invoke `notmuch-command' with ARGS. + +The caller may provide keyword arguments before ARGS. Currently +supported keyword arguments are: + + :stdin-string STRING - Write STRING to stdin + +If notmuch exits with a non-zero status, output from the process +will appear in a buffer named \"*Notmuch errors*\" and an error +will be signaled." + (with-temp-buffer + (let ((status (notmuch-call-notmuch--helper t args))) + (notmuch-check-exit-status status (cons notmuch-command args) + (buffer-string))))) + +(defun notmuch-call-notmuch-sexp (&rest args) + "Invoke `notmuch-command' with ARGS and return the parsed S-exp output. + +This is equivalent to `notmuch-call-notmuch-process', but parses +notmuch's output as an S-expression and returns the parsed value. +Like `notmuch-call-notmuch-process', if notmuch exits with a +non-zero status, this will report its output and signal an +error." + (with-temp-buffer + (let ((err-file (make-temp-file "nmerr"))) + (unwind-protect + (let ((status (notmuch-call-notmuch--helper (list t err-file) args)) + (err (with-temp-buffer + (insert-file-contents err-file) + (unless (eobp) + (buffer-string))))) + (notmuch-check-exit-status status (cons notmuch-command args) + (buffer-string) err) + (goto-char (point-min)) + (read (current-buffer))) + (delete-file err-file))))) + +(defun notmuch-start-notmuch (name buffer sentinel &rest args) + "Start and return an asynchronous notmuch command. + +This starts and returns an asynchronous process running +`notmuch-command' with ARGS. The exit status is checked via +`notmuch-check-async-exit-status'. Output written to stderr is +redirected and displayed when the process exits (even if the +process exits successfully). NAME and BUFFER are the same as in +`start-process'. SENTINEL is a process sentinel function to call +when the process exits, or nil for none. The caller must *not* +invoke `set-process-sentinel' directly on the returned process, +as that will interfere with the handling of stderr and the exit +status." + (let* ((command (or (executable-find notmuch-command) + (error "Command not found: %s" notmuch-command))) + (err-buffer (generate-new-buffer " *notmuch-stderr*")) + (proc (notmuch--make-process + :name name + :buffer buffer + :command (cons command args) + :connection-type 'pipe + :stderr err-buffer)) + (err-proc (get-buffer-process err-buffer))) + (process-put proc 'err-buffer err-buffer) + (process-put proc 'sub-sentinel sentinel) + (set-process-sentinel proc #'notmuch-start-notmuch-sentinel) + (set-process-sentinel err-proc #'notmuch-start-notmuch-error-sentinel) + proc)) + +(defun notmuch-start-notmuch-sentinel (proc event) + "Process sentinel function used by `notmuch-start-notmuch'." + (let* ((err-buffer (process-get proc 'err-buffer)) + (err (and (buffer-live-p err-buffer) + (not (zerop (buffer-size err-buffer))) + (with-current-buffer err-buffer (buffer-string)))) + (sub-sentinel (process-get proc 'sub-sentinel))) + (condition-case err + (progn + ;; Invoke the sub-sentinel, if any + (when sub-sentinel + (funcall sub-sentinel proc event)) + ;; Check the exit status. This will signal an error if the + ;; exit status is non-zero. Don't do this if the process + ;; buffer is dead since that means Emacs killed the process + ;; and there's no point in telling the user that (but we + ;; still check for and report stderr output below). + (when (buffer-live-p (process-buffer proc)) + (notmuch-check-async-exit-status proc event nil err)) + ;; If that didn't signal an error, then any error output was + ;; really warning output. Show warnings, if any. + (let ((warnings + (and err + (with-current-buffer err-buffer + (goto-char (point-min)) + (end-of-line) + ;; Show first line; stuff remaining lines in the + ;; errors buffer. + (let ((l1 (buffer-substring (point-min) (point)))) + (skip-chars-forward "\n") + (cons l1 (and (not (eobp)) + (buffer-substring (point) + (point-max))))))))) + (when warnings + (notmuch-logged-error (car warnings) (cdr warnings))))) + (error + ;; Emacs behaves strangely if an error escapes from a sentinel, + ;; so turn errors into messages. + (message "%s" (error-message-string err)))))) + +(defun notmuch-start-notmuch-error-sentinel (proc _event) + (unless (process-live-p proc) + (let ((buffer (process-buffer proc))) + (when (buffer-live-p buffer) + (kill-buffer buffer))))) + +(defvar-local notmuch-show-process-crypto nil) + +(defun notmuch--run-show (search-terms &optional duplicate) + "Return a list of threads of messages matching SEARCH-TERMS. + +A thread is a forest or list of trees. A tree is a two element +list where the first element is a message, and the second element +is a possibly empty forest of replies." + (let ((args '("show" "--format=sexp" "--format-version=5"))) + (when notmuch-show-process-crypto + (setq args (append args '("--decrypt=true")))) + (when duplicate + (setq args (append args (list (format "--duplicate=%d" duplicate))))) + (setq args (append args search-terms)) + (apply #'notmuch-call-notmuch-sexp args))) + +;;; Generic Utilities + +(defun notmuch-interactive-region () + "Return the bounds of the current interactive region. + +This returns (BEG END), where BEG and END are the bounds of the +region if the region is active, or both `point' otherwise." + (if (region-active-p) + (list (region-beginning) (region-end)) + (list (point) (point)))) + +(define-obsolete-function-alias + 'notmuch-search-interactive-region + 'notmuch-interactive-region + "notmuch 0.29") + +(defun notmuch--inline-override-types () + "Override mm-inline-override-types to stop application/* +parts from being displayed unless the user has customized +it themselves." + (if (equal mm-inline-override-types + (eval (car (get 'mm-inline-override-types 'standard-value)))) + (cons "application/.*" mm-inline-override-types) + mm-inline-override-types)) +;;; _ + +(provide 'notmuch-lib) + +;;; notmuch-lib.el ends here blob - /dev/null blob + 2c65a73b470e0fdaa6984704b6425e35ffe900cf (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-logo.svg @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + blob - /dev/null blob + c7b403cfe68f805baf186f64be64bd75f9cf3101 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-maildir-fcc.el @@ -0,0 +1,364 @@ +;;; notmuch-maildir-fcc.el --- inserting using a fcc handler -*- lexical-binding: t -*- + +;; Copyright © Jesse Rosenthal +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Jesse Rosenthal + +;;; Code: + +(require 'seq) + +(require 'message) + +(require 'notmuch-lib) + +(defvar notmuch-maildir-fcc-count 0) + +;;; Options + +(defcustom notmuch-fcc-dirs "sent" + "Determines the Fcc Header which says where to save outgoing mail. + +Three types of values are permitted: + +- nil: no Fcc header is added, + +- a string: the value of `notmuch-fcc-dirs' is the Fcc header to + be used. + +- an alist: the folder is chosen based on the From address of + the current message according to an alist mapping regular + expressions to folders or nil: + + ((\"Sebastian@SSpaeth.de\" . \"privat\") + (\"spaetz@sspaeth.de\" . \"OUTBOX.OSS\") + (\".*\" . \"defaultinbox\")) + + If none of the regular expressions match the From address, or + if the cdr of the matching entry is nil, then no Fcc header + will be added. + +If `notmuch-maildir-use-notmuch-insert' is set (the default) then +the header should be of the form \"folder +tag1 -tag2\" where +folder is the folder (relative to the notmuch mailstore) to store +the message in, and tag1 and tag2 are tag changes to apply to the +stored message. This string is split using `split-string-and-unquote', +so a folder name containing spaces can be specified by +quoting each space with an immediately preceding backslash +or surrounding the entire folder name in double quotes. + +If `notmuch-maildir-use-notmuch-insert' is nil then the Fcc +header should be the directory where the message should be +saved. A relative directory will be understood to specify a +directory within the notmuch mail store, (as set by the +database.path option in the notmuch configuration file). + +In all cases you will be prompted to create the folder or +directory if it does not exist yet when sending a mail." + + :type '(choice + (const :tag "No FCC header" nil) + (string :tag "A single folder") + (repeat :tag "A folder based on the From header" + (cons regexp (choice (const :tag "No FCC header" nil) + (string :tag "Folder"))))) + :require 'notmuch-fcc-initialization + :group 'notmuch-send) + +(defcustom notmuch-maildir-use-notmuch-insert t + "Should fcc use notmuch insert instead of simple fcc." + :type '(choice :tag "Fcc Method" + (const :tag "Use notmuch insert" t) + (const :tag "Use simple fcc" nil)) + :group 'notmuch-send) + +;;; Functions which set up the fcc header in the message buffer. + +(defun notmuch-fcc-header-setup () + "Add an Fcc header to the current message buffer. + +If the Fcc header is already set, then keep it as-is. +Otherwise set it according to `notmuch-fcc-dirs'." + (let ((subdir + (cond + ((or (not notmuch-fcc-dirs) + (message-field-value "Fcc")) + ;; Nothing set or an existing header. + nil) + ((stringp notmuch-fcc-dirs) + notmuch-fcc-dirs) + ((and (listp notmuch-fcc-dirs) + (stringp (car notmuch-fcc-dirs))) + ;; Old style - no longer works. + (error "Invalid `notmuch-fcc-dirs' setting (old style)")) + ((listp notmuch-fcc-dirs) + (if-let ((match (seq-some (let ((from (message-field-value "From"))) + (pcase-lambda (`(,regexp . ,folder)) + (and (string-match-p regexp from) + (cons t folder)))) + notmuch-fcc-dirs))) + (cdr match) + (message "No Fcc header added.") + nil)) + (t + (error "Invalid `notmuch-fcc-dirs' setting (neither string nor list)"))))) + (when subdir + (if notmuch-maildir-use-notmuch-insert + (notmuch-maildir-add-notmuch-insert-style-fcc-header subdir) + (notmuch-maildir-add-file-style-fcc-header subdir))))) + +(defun notmuch-maildir-add-notmuch-insert-style-fcc-header (subdir) + ;; Notmuch insert does not accept absolute paths, so check the user + ;; really want this header inserted. + (when (or (not (= (elt subdir 0) ?/)) + (y-or-n-p (format "Fcc header %s is an absolute path %s %s" subdir + "and notmuch insert is requested." + "Insert header anyway? "))) + (message-add-header (concat "Fcc: " subdir)))) + +(defun notmuch-maildir-add-file-style-fcc-header (subdir) + (message-add-header + (concat "Fcc: " + (file-truename + ;; If the resulting directory is not an absolute path, + ;; prepend the standard notmuch database path. + (if (= (elt subdir 0) ?/) + subdir + (concat (notmuch-database-path) "/" subdir)))))) + +;;; Functions for saving a message using either method. + +(defmacro with-temporary-notmuch-message-buffer (&rest body) + "Set-up a temporary copy of the current message-mode buffer." + `(save-restriction + (widen) + (let ((case-fold-search t) + (buf (current-buffer)) + (mml-externalize-attachments message-fcc-externalize-attachments)) + (with-current-buffer (get-buffer-create " *message temp*") + (message-clone-locals buf) ;; for message-encoded-mail-cache + (erase-buffer) + (insert-buffer-substring buf) + ,@body)))) + +(defun notmuch-maildir-setup-message-for-saving () + "Setup message for saving. + +This should be called on a temporary copy. +This is taken from the function message-do-fcc." + (if (not message-encoded-mail-cache) + (message-encode-message-body) + (erase-buffer) + (insert message-encoded-mail-cache)) + (save-restriction + (message-narrow-to-headers) + (mail-encode-encoded-word-buffer)) + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "$") + nil t) + (replace-match "" t t ))) + +(defun notmuch-maildir-message-do-fcc () + "Process Fcc headers in the current buffer. + +This is a rearranged version of message mode's message-do-fcc." + (let (files file) + (save-excursion + (save-restriction + (message-narrow-to-headers) + (setq file (message-fetch-field "fcc" t))) + (when file + (with-temporary-notmuch-message-buffer + (notmuch-maildir-setup-message-for-saving) + (save-restriction + (message-narrow-to-headers) + (while (setq file (message-fetch-field "fcc" t)) + (push file files) + (message-remove-header "fcc" nil t))) + ;; Process FCC operations. + (mapc #'notmuch-fcc-handler files) + (kill-buffer (current-buffer))))))) + +(defun notmuch-fcc-handler (fcc-header) + "Store message with notmuch insert or normal (file) fcc. + +If `notmuch-maildir-use-notmuch-insert' is set then store the +message using notmuch insert. Otherwise store the message using +normal fcc." + (message "Doing Fcc...") + (if notmuch-maildir-use-notmuch-insert + (notmuch-maildir-fcc-with-notmuch-insert fcc-header) + (notmuch-maildir-fcc-file-fcc fcc-header)) + (message "Doing Fcc...done")) + +;;; Functions for saving a message using notmuch insert. + +(defun notmuch-maildir-notmuch-insert-current-buffer (folder &optional create tags) + "Use notmuch insert to put the current buffer in the database. + +This inserts the current buffer as a message into the notmuch +database in folder FOLDER. If CREATE is non-nil it will supply +the --create-folder flag to create the folder if necessary. TAGS +should be a list of tag changes to apply to the inserted message." + (apply 'notmuch-call-notmuch-process + :stdin-string (buffer-string) "insert" + (append (and create (list "--create-folder")) + (list (concat "--folder=" folder)) + tags))) + +(defun notmuch-maildir-fcc-with-notmuch-insert (fcc-header &optional create) + "Store message with notmuch insert. + +The fcc-header should be of the form \"folder +tag1 -tag2\" where +folder is the folder (relative to the notmuch mailstore) to store +the message in, and tag1 and tag2 are tag changes to apply to the +stored message. This string is split using `split-string-and-unquote', +so a folder name containing spaces can be specified by +quoting each space with an immediately preceding backslash +or surrounding the entire folder name in double quotes. + +If CREATE is non-nil then create the folder if necessary." + (pcase-let ((`(,folder . ,tags) + (split-string-and-unquote fcc-header))) + (condition-case nil + (notmuch-maildir-notmuch-insert-current-buffer folder create tags) + ;; Since there are many reasons notmuch insert could fail, e.g., + ;; locked database, non-existent folder (which could be due to a + ;; typo, or just the user want a new folder, let the user decide + ;; how to deal with it. + (error + (let ((response (read-char-choice "Insert failed: \ +\(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " '(?r ?c ?i ?e)))) + (cl-case response + (?r (notmuch-maildir-fcc-with-notmuch-insert fcc-header)) + (?c (notmuch-maildir-fcc-with-notmuch-insert fcc-header t)) + (?i t) + (?e (notmuch-maildir-fcc-with-notmuch-insert + (read-from-minibuffer "Fcc header: " fcc-header))))))))) + +;;; Functions for saving a message using file fcc. + +(defun notmuch-maildir-fcc-host-fixer (hostname) + (replace-regexp-in-string "/\\|:" + (lambda (s) + (cond ((string-equal s "/") "\\057") + ((string-equal s ":") "\\072") + (t s))) + hostname + t + t)) + +(defun notmuch-maildir-fcc-make-uniq-maildir-id () + (let* ((ftime (float-time)) + (microseconds (mod (* 1000000 ftime) 1000000)) + (hostname (notmuch-maildir-fcc-host-fixer (system-name)))) + (cl-incf notmuch-maildir-fcc-count) + (format "%d.%d_%d_%d.%s" + ftime + (emacs-pid) + microseconds + notmuch-maildir-fcc-count + hostname))) + +(defun notmuch-maildir-fcc-dir-is-maildir-p (dir) + (and (file-exists-p (concat dir "/cur/")) + (file-exists-p (concat dir "/new/")) + (file-exists-p (concat dir "/tmp/")))) + +(defun notmuch-maildir-fcc-create-maildir (path) + (cond ((or (not (file-exists-p path)) (file-directory-p path)) + (make-directory (concat path "/cur/") t) + (make-directory (concat path "/new/") t) + (make-directory (concat path "/tmp/") t)) + ((file-regular-p path) + (error "%s is a file. Can't create maildir." path)) + (t + (error "I don't know how to create a maildir here")))) + +(defun notmuch-maildir-fcc-save-buffer-to-tmp (destdir) + "Returns the msg id of the message written to the temp directory +if successful, nil if not." + (let ((msg-id (notmuch-maildir-fcc-make-uniq-maildir-id))) + (while (file-exists-p (concat destdir "/tmp/" msg-id)) + (setq msg-id (notmuch-maildir-fcc-make-uniq-maildir-id))) + (cond ((notmuch-maildir-fcc-dir-is-maildir-p destdir) + (write-file (concat destdir "/tmp/" msg-id)) + msg-id) + (t + (error "Can't write to %s. Not a maildir." destdir))))) + +(defun notmuch-maildir-fcc-move-tmp-to-new (destdir msg-id) + (add-name-to-file + (concat destdir "/tmp/" msg-id) + (concat destdir "/new/" msg-id ":2,"))) + +(defun notmuch-maildir-fcc-move-tmp-to-cur (destdir msg-id &optional mark-seen) + (add-name-to-file + (concat destdir "/tmp/" msg-id) + (concat destdir "/cur/" msg-id ":2," (and mark-seen "S")))) + +(defun notmuch-maildir-fcc-file-fcc (fcc-header) + "Write the message to the file specified by FCC-HEADER. + +If that fails, then offer the user a chance to correct the header +or filesystem." + (if (notmuch-maildir-fcc-dir-is-maildir-p fcc-header) + (notmuch-maildir-fcc-write-buffer-to-maildir fcc-header t) + ;; The fcc-header is not a valid maildir see if the user wants to + ;; fix it in some way. + (let* ((prompt (format "Fcc %s is not a maildir: \ +\(r)etry, (c)reate folder, (i)gnore, or (e)dit the header? " fcc-header)) + (response (read-char-choice prompt '(?r ?c ?i ?e)))) + (cl-case response + (?r (notmuch-maildir-fcc-file-fcc fcc-header)) + (?c (if (file-writable-p fcc-header) + (notmuch-maildir-fcc-create-maildir fcc-header) + (message "No permission to create %s." fcc-header) + (sit-for 2)) + (notmuch-maildir-fcc-file-fcc fcc-header)) + (?i t) + (?e (notmuch-maildir-fcc-file-fcc + (read-from-minibuffer "Fcc header: " fcc-header))))))) + +(defun notmuch-maildir-fcc-write-buffer-to-maildir (destdir &optional mark-seen) + "Write the current buffer to maildir destdir. + +If mark-seen is non-nil, then write it to \"cur/\", and mark it +as read, otherwise write it to \"new/\". Return t if successful, +and nil otherwise." + (let ((orig-buffer (buffer-name))) + (with-temp-buffer + (insert-buffer-substring orig-buffer) + (catch 'link-error + (let ((msg-id (notmuch-maildir-fcc-save-buffer-to-tmp destdir))) + (when msg-id + (condition-case nil + (if mark-seen + (notmuch-maildir-fcc-move-tmp-to-cur destdir msg-id t) + (notmuch-maildir-fcc-move-tmp-to-new destdir msg-id)) + (file-already-exists + (throw 'link-error nil)))) + (delete-file (concat destdir "/tmp/" msg-id)))) + t))) + +;;; _ + +(provide 'notmuch-maildir-fcc) + +;;; notmuch-maildir-fcc.el ends here blob - /dev/null blob + 0856a2e943e6e4cb38d38759d976a512651edb4b (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-message.el @@ -0,0 +1,76 @@ +;;; notmuch-message.el --- message-mode functions specific to notmuch -*- lexical-binding: t -*- +;; +;; Copyright © Jesse Rosenthal +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Jesse Rosenthal + +;;; Code: + +(require 'cl-lib) +(require 'pcase) +(require 'subr-x) + +(require 'message) +(require 'notmuch-tag) + +(defcustom notmuch-message-replied-tags '("+replied") + "List of tag changes to apply to a message when it has been replied to. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message being replied to. + +For example, if you wanted to add a \"replied\" tag and remove +the \"inbox\" and \"todo\" tags, you would set: + (\"+replied\" \"-inbox\" \"-todo\")" + :type '(repeat string) + :group 'notmuch-send) + +(defcustom notmuch-message-forwarded-tags '("+forwarded") + "List of tag changes to apply to a message when it has been forwarded. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message being forwarded. + +For example, if you wanted to add a \"forwarded\" tag and remove +the \"inbox\" tag, you would set: + (\"+forwarded\" \"-inbox\")" + :type '(repeat string) + :group 'notmuch-send) + +(defvar-local notmuch-message-queued-tag-changes nil + "List of tag changes to be applied when sending a message. + +A list of queries and tag changes that are to be applied to them +when the message that was composed in the current buffer is being +send. Each item in this list is a list of strings, where the +first is a notmuch query and the rest are the tag changes to be +applied to the matching messages.") + +(defun notmuch-message-apply-queued-tag-changes () + ;; Apply the tag changes queued in the buffer-local variable + ;; notmuch-message-queued-tag-changes. + (pcase-dolist (`(,query . ,tags) notmuch-message-queued-tag-changes) + (notmuch-tag query tags))) + +(add-hook 'message-send-hook 'notmuch-message-apply-queued-tag-changes) + +(provide 'notmuch-message) + +;;; notmuch-message.el ends here blob - /dev/null blob + 74c62aafd28d69eb5de5135ee4f9f53c481d72e4 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-mua.el @@ -0,0 +1,681 @@ +;;; notmuch-mua.el --- emacs style mail-user-agent -*- lexical-binding: t -*- +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Edmondson + +;;; Code: + +(eval-when-compile (require 'subr-x)) + +(require 'message) +(require 'gmm-utils) +(require 'mm-view) +(require 'format-spec) + +(require 'notmuch-lib) +(require 'notmuch-address) +(require 'notmuch-draft) +(require 'notmuch-message) + +(declare-function notmuch-show-insert-body "notmuch-show" (msg body depth)) +(declare-function notmuch-fcc-header-setup "notmuch-maildir-fcc" ()) +(declare-function notmuch-maildir-message-do-fcc "notmuch-maildir-fcc" ()) +(declare-function notmuch-draft-postpone "notmuch-draft" ()) +(declare-function notmuch-draft-save "notmuch-draft" ()) + +(defvar notmuch-show-indent-multipart) +(defvar notmuch-show-insert-header-p-function) +(defvar notmuch-show-max-text-part-size) +(defvar notmuch-show-insert-text/plain-hook) + +;;; Options + +(defcustom notmuch-mua-send-hook nil + "Hook run before sending messages." + :type 'hook + :group 'notmuch-send + :group 'notmuch-hooks) + +(defcustom notmuch-mua-compose-in 'current-window + "Where to create the mail buffer used to compose a new message. +Possible values are `current-window' (default), `new-window' and +`new-frame'. If set to `current-window', the mail buffer will be +displayed in the current window, so the old buffer will be +restored when the mail buffer is killed. If set to `new-window' +or `new-frame', the mail buffer will be displayed in a new +window/frame that will be destroyed when the buffer is killed. +You may want to customize `message-kill-buffer-on-exit' +accordingly." + :group 'notmuch-send + :type '(choice (const :tag "Compose in the current window" current-window) + (const :tag "Compose mail in a new window" new-window) + (const :tag "Compose mail in a new frame" new-frame))) + +(defcustom notmuch-mua-user-agent-function nil + "Function used to generate a `User-Agent:' string. +If this is `nil' then no `User-Agent:' will be generated." + :type '(choice (const :tag "No user agent string" nil) + (const :tag "Full" notmuch-mua-user-agent-full) + (const :tag "Notmuch" notmuch-mua-user-agent-notmuch) + (const :tag "Emacs" notmuch-mua-user-agent-emacs) + (function :tag "Custom user agent function" + :value notmuch-mua-user-agent-full)) + :group 'notmuch-send) + +(defcustom notmuch-mua-hidden-headers nil + "Headers that are added to the `message-mode' hidden headers list." + :type '(repeat string) + :group 'notmuch-send) + +(defcustom notmuch-identities nil + "Identities that can be used as the From: address when composing a new message. + +If this variable is left unset, then a list will be constructed from the +name and addresses configured in the notmuch configuration file." + :type '(repeat string) + :group 'notmuch-send) + +(defcustom notmuch-always-prompt-for-sender nil + "Always prompt for the From: address when composing or forwarding a message. + +This is not taken into account when replying to a message, because in that case +the From: header is already filled in by notmuch." + :type 'boolean + :group 'notmuch-send) + +(defgroup notmuch-reply nil + "Replying to messages in notmuch." + :group 'notmuch) + +(defcustom notmuch-mua-cite-function 'message-cite-original + "Function for citing an original message. + +Predefined functions include `message-cite-original' and +`message-cite-original-without-signature'. Note that these +functions use `mail-citation-hook' if that is non-nil." + :type '(radio (function-item message-cite-original) + (function-item message-cite-original-without-signature) + (function-item sc-cite-original) + (function :tag "Other")) + :link '(custom-manual "(message)Insertion Variables") + :group 'notmuch-reply) + +(defcustom notmuch-mua-reply-insert-header-p-function + 'notmuch-show-reply-insert-header-p-never + "Function to decide which parts get a header when replying. + +This function specifies which parts of a mime message with +multiple parts get a header." + :type '(radio (const :tag "No part headers" + notmuch-show-reply-insert-header-p-never) + (const :tag "All except multipart/* and hidden parts" + notmuch-show-reply-insert-header-p-trimmed) + (const :tag "Only for included text parts" + notmuch-show-reply-insert-header-p-minimal) + (const :tag "Exactly as in show view" + notmuch-show-insert-header-p) + (function :tag "Other")) + :group 'notmuch-reply) + +(defcustom notmuch-mua-attachment-regexp + "\\b\\(attache\?ment\\|attached\\|attach\\|pi[èe]ce\s+jointe?\\)\\b" + "Message body text indicating that an attachment is expected. + +This is not used unless `notmuch-mua-attachment-check' is added +to `notmuch-mua-send-hook'." + :type 'regexp + :group 'notmuch-send) + +(defcustom notmuch-mua-subject-regexp + "[[:blank:]]*$" + "Message subject indicating that something may be amiss. +By default, this checks for empty subject lines. + +This is not used unless `notmuch-mua-subject-check' is added to +`notmuch-mua-send-hook'." + :type 'regexp + :group 'notmuch-send) + +;;; Various functions + +(defun notmuch-mua-attachment-check () + "Signal an error an attachement is expected but missing. + +Signal an error if the message text indicates that an attachment +is expected but no MML referencing an attachment is found. + +Typically this is added to `notmuch-mua-send-hook'." + (when (and + ;; When the message mentions attachment... + (save-excursion + (message-goto-body) + ;; Limit search from reaching other possible parts of the message + (let ((search-limit (search-forward "\n<#" nil t))) + (message-goto-body) + (cl-loop while (re-search-forward notmuch-mua-attachment-regexp + search-limit t) + ;; For every instance of the "attachment" string + ;; found, examine the text properties. If the text + ;; has either a `face' or `syntax-table' property + ;; then it is quoted text and should *not* cause the + ;; user to be asked about a missing attachment. + if (let ((props (text-properties-at (match-beginning 0)))) + (not (or (memq 'syntax-table props) + (memq 'face props)))) + return t + finally return nil))) + ;; ...but doesn't have a part with a filename... + (save-excursion + (message-goto-body) + (not (re-search-forward "^<#part [^>]*filename=" nil t))) + ;; ...and that's not okay... + (not (y-or-n-p "Attachment mentioned, but no attachment - is that okay?"))) + ;; ...signal an error. + (error "Missing attachment"))) + +(defun notmuch-mua-subject-check () + "Signal an error if the subject seems amiss. +More precisely, if the subject conforms to +`notmuch-mua-subject-regexp'. + +Typically this is added to `notmuch-mua-send-hook'." + (or (save-excursion + (message-goto-subject) + (message-beginning-of-header t) + (not (looking-at-p notmuch-mua-subject-regexp))) + (y-or-n-p "Subject may be erroneous – is that okay?") + (error "Erroneous subject"))) + +(defun notmuch-mua-get-switch-function () + "Get a switch function according to `notmuch-mua-compose-in'." + (pcase notmuch-mua-compose-in + ('current-window 'switch-to-buffer) + ('new-window 'switch-to-buffer-other-window) + ('new-frame 'switch-to-buffer-other-frame) + (_ (error "Invalid value for `notmuch-mua-compose-in'")))) + +(defun notmuch-mua-maybe-set-window-dedicated () + "Set the selected window as dedicated according to `notmuch-mua-compose-in'." + (when (or (eq notmuch-mua-compose-in 'new-frame) + (eq notmuch-mua-compose-in 'new-window)) + (set-window-dedicated-p (selected-window) t))) + +(defun notmuch-mua-user-agent-full () + "Generate a `User-Agent:' string suitable for notmuch." + (concat (notmuch-mua-user-agent-notmuch) + " " + (notmuch-mua-user-agent-emacs))) + +(defun notmuch-mua-user-agent-notmuch () + "Generate a `User-Agent:' string suitable for notmuch." + (let ((notmuch-version (if (string= notmuch-emacs-version "unknown") + (notmuch-cli-version) + notmuch-emacs-version))) + (concat "Notmuch/" notmuch-version " (https://notmuchmail.org)"))) + +(defun notmuch-mua-user-agent-emacs () + "Generate a `User-Agent:' string suitable for notmuch." + (concat "Emacs/" emacs-version " (" system-configuration ")")) + +(defun notmuch-mua-add-more-hidden-headers () + "Add some headers to the list that are hidden by default." + (mapc (lambda (header) + (unless (member header message-hidden-headers) + (push header message-hidden-headers))) + notmuch-mua-hidden-headers)) + +(defun notmuch-mua-reply-crypto (parts) + "Add mml sign-encrypt flag if any part of original message is encrypted." + (cl-loop for part in parts + for type = (plist-get part :content-type) + if (notmuch-match-content-type type "multipart/encrypted") + do (mml-secure-message-sign-encrypt) + else if (notmuch-match-content-type type "multipart/*") + do (notmuch-mua-reply-crypto (plist-get part :content)))) + +;; There is a bug in Emacs' message.el that results in a newline +;; not being inserted after the References header, so the next header +;; is concatenated to the end of it. This function fixes the problem, +;; while guarding against the possibility that some current or future +;; version of emacs has the bug fixed. +(defun notmuch-mua-insert-references (original-func header references) + (funcall original-func header references) + (unless (bolp) (insert "\n"))) + +;;; Mua reply + +(defun notmuch-mua-reply (query-string &optional sender reply-all duplicate) + (let* ((duparg (and duplicate (list (format "--duplicate=%d" duplicate)))) + (args `("reply" "--format=sexp" "--format-version=5" ,@duparg)) + (process-crypto notmuch-show-process-crypto) + reply + original) + (when process-crypto + (setq args (append args '("--decrypt=true")))) + (if reply-all + (setq args (append args '("--reply-to=all"))) + (setq args (append args '("--reply-to=sender")))) + (setq args (append args (list query-string))) + ;; Get the reply object as SEXP, and parse it into an elisp object. + (setq reply (apply #'notmuch-call-notmuch-sexp args)) + ;; Extract the original message to simplify the following code. + (setq original (plist-get reply :original)) + ;; Extract the headers of both the reply and the original message. + (let* ((original-headers (plist-get original :headers)) + (reply-headers (plist-get reply :reply-headers))) + ;; If sender is non-nil, set the From: header to its value. + (when sender + (plist-put reply-headers :From sender)) + (let + ;; Overlay the composition window on that being used to read + ;; the original message. + ((same-window-regexps '("\\*mail .*"))) + ;; We modify message-header-format-alist to get around + ;; a bug in message.el. See the comment above on + ;; notmuch-mua-insert-references. + (let ((message-header-format-alist + (cl-loop for pair in message-header-format-alist + if (eq (car pair) 'References) + collect (cons 'References + (apply-partially + 'notmuch-mua-insert-references + (cdr pair))) + else + collect pair))) + (notmuch-mua-mail (plist-get reply-headers :To) + (notmuch-sanitize (plist-get reply-headers :Subject)) + (notmuch-headers-plist-to-alist reply-headers) + nil (notmuch-mua-get-switch-function)))) + ;; Create a buffer-local queue for tag changes triggered when + ;; sending the reply. + (when notmuch-message-replied-tags + (setq notmuch-message-queued-tag-changes + (list (cons query-string notmuch-message-replied-tags)))) + ;; Insert the message body - but put it in front of the signature + ;; if one is present, and after any other content + ;; message*setup-hooks may have added to the message body already. + (save-restriction + (message-goto-body) + (narrow-to-region (point) (point-max)) + (goto-char (point-max)) + (if (re-search-backward message-signature-separator nil t) + (when message-signature-insert-empty-line + (forward-line -1)) + (goto-char (point-max)))) + (let ((from (plist-get original-headers :From)) + (date (plist-get original-headers :Date)) + (start (point))) + ;; notmuch-mua-cite-function constructs a citation line based + ;; on the From and Date headers of the original message, which + ;; are assumed to be in the buffer. + (insert "From: " from "\n") + (insert "Date: " date "\n\n") + (insert + (with-temp-buffer + (let + ;; Don't attempt to clean up messages, excerpt + ;; citations, etc. in the original message before + ;; quoting. + ((notmuch-show-insert-text/plain-hook nil) + ;; Don't omit long parts. + (notmuch-show-max-text-part-size 0) + ;; Insert headers for parts as appropriate for replying. + (notmuch-show-insert-header-p-function + notmuch-mua-reply-insert-header-p-function) + ;; Ensure that any encrypted parts are + ;; decrypted during the generation of the reply + ;; text. + (notmuch-show-process-crypto process-crypto) + ;; Don't indent multipart sub-parts. + (notmuch-show-indent-multipart nil) + ;; Stop certain mime types from being inlined + (mm-inline-override-types (notmuch--inline-override-types))) + ;; We don't want sigstatus buttons (an information leak and usually wrong anyway). + (cl-letf (((symbol-function 'notmuch-crypto-insert-sigstatus-button) #'ignore) + ((symbol-function 'notmuch-crypto-insert-encstatus-button) #'ignore)) + (notmuch-show-insert-body original (plist-get original :body) 0) + (buffer-substring-no-properties (point-min) (point-max)))))) + (set-mark (point)) + (goto-char start) + ;; Quote the original message according to the user's configured style. + (funcall notmuch-mua-cite-function))) + ;; Crypto processing based crypto content of the original message + (when process-crypto + (notmuch-mua-reply-crypto (plist-get original :body)))) + ;; Push mark right before signature, if any. + (message-goto-signature) + (unless (eobp) + (end-of-line -1)) + (push-mark) + (message-goto-body) + (set-buffer-modified-p nil)) + +;;; Mode and keymap + +(defvar notmuch-message-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap message-send-and-exit] #'notmuch-mua-send-and-exit) + (define-key map [remap message-send] #'notmuch-mua-send) + (define-key map (kbd "C-c C-p") #'notmuch-draft-postpone) + (define-key map (kbd "C-x C-s") #'notmuch-draft-save) + map) + "Keymap for `notmuch-message-mode'.") + +(define-derived-mode notmuch-message-mode message-mode "Message[Notmuch]" + "Notmuch message composition mode. Mostly like `message-mode'." + (notmuch-address-setup) + (when (boundp 'untrusted-content) + (setq untrusted-content t))) + +(put 'notmuch-message-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) + +;;; New messages + +(defun notmuch-mua-pop-to-buffer (name switch-function) + "Pop to buffer NAME, and warn if it already exists and is modified. +Like `message-pop-to-buffer' but enable `notmuch-message-mode' +instead of `message-mode' and SWITCH-FUNCTION is mandatory." + (let ((buffer (get-buffer name))) + (if (and buffer + (buffer-name buffer)) + (let ((window (get-buffer-window buffer 0))) + (if window + ;; Raise the frame already displaying the message buffer. + (progn + (select-frame-set-input-focus (window-frame window)) + (select-window window)) + (funcall switch-function buffer) + (set-buffer buffer)) + (when (buffer-modified-p) + (if (y-or-n-p "Message already being composed; erase? ") + (message nil) + (error "Message being composed")))) + (funcall switch-function name) + (set-buffer name)) + (erase-buffer) + (notmuch-message-mode))) + +(defun notmuch-mua--remove-dont-reply-to-names () + (when-let* ((nr (if (functionp message-dont-reply-to-names) + message-dont-reply-to-names + (gmm-regexp-concat message-dont-reply-to-names))) + (nr-filter + (if (functionp nr) + (lambda (mail) (and (not (funcall nr mail)) mail)) + (lambda (mail) (and (not (string-match-p nr mail)) mail))))) + (dolist (header '("To" "Cc")) + (when-let ((v (message-fetch-field header))) + (let* ((tokens (mapcar #'string-trim (message-tokenize-header v))) + (good-tokens (delq nil (mapcar nr-filter tokens))) + (addr (and good-tokens (mapconcat #'identity good-tokens ", ")))) + (message-replace-header header addr)))))) + +;;;###autoload +(defun notmuch-mua-mail (&optional to subject other-headers _continue + switch-function yank-action send-actions + return-action &rest _ignored) + "Invoke the notmuch mail composition window. + +The position of point when the function returns differs depending +on the values of TO and SUBJECT. If both are non-nil, point is +moved to the message's body. If SUBJECT is nil but TO isn't, +point is moved to the \"Subject:\" header. Otherwise, point is +moved to the \"To:\" header." + (interactive) + (when notmuch-mua-user-agent-function + (let ((user-agent (funcall notmuch-mua-user-agent-function))) + (unless (string-empty-p user-agent) + (push (cons 'User-Agent user-agent) other-headers)))) + (notmuch-mua-pop-to-buffer (message-buffer-name "mail" to) + (or switch-function + (notmuch-mua-get-switch-function))) + (let ((headers + (append + ;; The following is copied from `message-mail' + `((To . ,(or to "")) (Subject . ,(or subject ""))) + ;; C-h f compose-mail says that headers should be specified as + ;; (string . value); however all the rest of message expects + ;; headers to be symbols, not strings (eg message-header-format-alist). + ;; https://lists.gnu.org/archive/html/emacs-devel/2011-01/msg00337.html + ;; We need to convert any string input, eg from rmail-start-mail. + (dolist (h other-headers other-headers) + (when (stringp (car h)) + (setcar h (intern (capitalize (car h)))))))) + ;; Cause `message-setup-1' to do things relevant for mail, + ;; such as observe `message-default-mail-headers'. + (message-this-is-mail t)) + (unless (assq 'From headers) + (push (cons 'From (message-make-from + (notmuch-user-name) + (notmuch-user-primary-email))) + headers)) + (message-setup-1 headers yank-action send-actions return-action)) + (notmuch-fcc-header-setup) + (notmuch-mua--remove-dont-reply-to-names) + (message-sort-headers) + (message-hide-headers) + (set-buffer-modified-p nil) + (notmuch-mua-maybe-set-window-dedicated) + (cond + ((and to subject) (message-goto-body)) + (to (message-goto-subject)) + (t (message-goto-to)))) + +(defvar notmuch-mua-sender-history nil) + +(defun notmuch-mua-prompt-for-sender () + "Prompt for a sender from the user's configured identities." + (if notmuch-identities + (completing-read "Send mail from: " notmuch-identities + nil nil nil 'notmuch-mua-sender-history + (car notmuch-identities)) + (let* ((name (notmuch-user-name)) + (addrs (cons (notmuch-user-primary-email) + (notmuch-user-other-email))) + (address + (completing-read (concat "Sender address for " name ": ") addrs + nil nil nil 'notmuch-mua-sender-history + (car addrs)))) + (message-make-from name address)))) + +(put 'notmuch-mua-new-mail 'notmuch-prefix-doc "... and prompt for sender") +(defun notmuch-mua-new-mail (&optional prompt-for-sender) + "Compose new mail. + +If PROMPT-FOR-SENDER is non-nil, the user will be prompted for +the From: address first." + (interactive "P") + (let ((other-headers + (and (or prompt-for-sender notmuch-always-prompt-for-sender) + (list (cons 'From (notmuch-mua-prompt-for-sender)))))) + (notmuch-mua-mail nil nil other-headers nil (notmuch-mua-get-switch-function)))) + +(defun notmuch-mua-new-forward-messages (messages &optional prompt-for-sender) + "Compose a new message forwarding MESSAGES. + +If PROMPT-FOR-SENDER is non-nil, the user will be prompteed for +the From: address." + (let* ((other-headers + (and (or prompt-for-sender notmuch-always-prompt-for-sender) + (list (cons 'From (notmuch-mua-prompt-for-sender))))) + ;; Comes from the first message and is applied later. + forward-subject + ;; List of accumulated message-references of forwarded messages. + forward-references + ;; List of corresponding message-query. + forward-queries) + ;; Generate the template for the outgoing message. + (notmuch-mua-mail nil "" other-headers nil (notmuch-mua-get-switch-function)) + (save-excursion + ;; Insert all of the forwarded messages. + (mapc (lambda (id) + (let ((temp-buffer (get-buffer-create + (concat "*notmuch-fwd-raw-" id "*")))) + ;; Get the raw version of this message in the buffer. + (with-current-buffer temp-buffer + (erase-buffer) + (let ((coding-system-for-read 'no-conversion)) + (notmuch--call-process notmuch-command nil t nil + "show" "--format=raw" id)) + ;; Because we process the messages in reverse order, + ;; always generate a forwarded subject, then use the + ;; last (i.e. first) one. + (setq forward-subject (message-make-forward-subject)) + (push (message-fetch-field "Message-ID") forward-references) + (push id forward-queries)) + ;; Make a copy ready to be forwarded in the + ;; composition buffer. + (message-forward-make-body temp-buffer) + ;; Kill the temporary buffer. + (kill-buffer temp-buffer))) + ;; `message-forward-make-body' always puts the message at + ;; the top, so do them in reverse order. + (reverse messages)) + ;; Add in the appropriate subject. + (save-restriction + (message-narrow-to-headers) + (message-remove-header "Subject") + (message-add-header (concat "Subject: " forward-subject)) + (message-remove-header "References") + (message-add-header (concat "References: " + (mapconcat 'identity forward-references " ")))) + ;; Create a buffer-local queue for tag changes triggered when + ;; sending the message. + (when notmuch-message-forwarded-tags + (setq notmuch-message-queued-tag-changes + (cl-loop for id in forward-queries + collect + (cons id notmuch-message-forwarded-tags)))) + ;; `message-forward-make-body' shows the User-agent header. Hide + ;; it again. + (message-hide-headers) + (set-buffer-modified-p nil)))) + +(defun notmuch-mua-new-reply (query-string &optional prompt-for-sender reply-all duplicate) + "Compose a reply to the message identified by QUERY-STRING. + +If PROMPT-FOR-SENDER is non-nil, the user will be prompted for +the From: address first. If REPLY-ALL is non-nil, the message +will be addressed to all recipients of the source message. If +DUPLICATE is non-nil, based the reply on that duplicate file" + ;; `select-active-regions' is t by default. The reply insertion code + ;; sets the region to the quoted message to make it easy to delete + ;; (kill-region or C-w). These two things combine to put the quoted + ;; message in the primary selection. + ;; + ;; This is not what the user wanted and is a privacy risk (accidental + ;; pasting of the quoted message). We can avoid some of the problems + ;; by let-binding select-active-regions to nil. This fixes if the + ;; primary selection was previously in a non-emacs window but not if + ;; it was in an emacs window. To avoid the problem in the latter case + ;; we deactivate mark. + (let ((sender (and prompt-for-sender + (notmuch-mua-prompt-for-sender))) + (select-active-regions nil)) + (notmuch-mua-reply query-string sender reply-all duplicate) + (deactivate-mark))) + +;;; Checks + +(defun notmuch-mua-check-no-misplaced-secure-tag () + "Query user if there is a misplaced secure mml tag. + +Emacs message-send will (probably) ignore a secure mml tag unless +it is at the start of the body. Returns t if there is no such +tag, or the user confirms they mean it." + (save-excursion + (let ((body-start (progn (message-goto-body) (point)))) + (goto-char (point-max)) + (or + ;; We are always fine if there is no secure tag. + (not (search-backward "<#secure" nil t)) + ;; There is a secure tag, so it must be at the start of the + ;; body, with no secure tag earlier (i.e., in the headers). + (and (= (point) body-start) + (not (search-backward "<#secure" nil t))) + ;; The user confirms they means it. + (yes-or-no-p "\ +There is a <#secure> tag not at the start of the body. It is +likely that the message will be sent unsigned and unencrypted. +Really send? "))))) + +(defun notmuch-mua-check-secure-tag-has-newline () + "Query if the secure mml tag has a newline following it. + +Emacs message-send will (probably) ignore a correctly placed +secure mml tag unless it is followed by a newline. Returns t if +any secure tag is followed by a newline, or the user confirms +they mean it." + (save-excursion + (message-goto-body) + (or + ;; There is no (correctly placed) secure tag. + (not (looking-at "<#secure")) + ;; The secure tag is followed by a newline. + (looking-at "<#secure[^\n>]*>\n") + ;; The user confirms they means it. + (yes-or-no-p "\ +The <#secure> tag at the start of the body is not followed by a +newline. It is likely that the message will be sent unsigned and +unencrypted. Really send? ")))) + +;;; Finishing commands + +(defun notmuch-mua-send-common (arg &optional exit) + (interactive "P") + (run-hooks 'notmuch-mua-send-hook) + (when (and (notmuch-mua-check-no-misplaced-secure-tag) + (notmuch-mua-check-secure-tag-has-newline)) + (cl-letf (((symbol-function 'message-do-fcc) + #'notmuch-maildir-message-do-fcc)) + (if exit + (message-send-and-exit arg) + (message-send arg))))) + +;;;###autoload +(defun notmuch-mua-send-and-exit (&optional arg) + (interactive "P") + (notmuch-mua-send-common arg t)) + +;;;###autoload +(defun notmuch-mua-send (&optional arg) + (interactive "P") + (notmuch-mua-send-common arg)) + +;;;###autoload +(defun notmuch-mua-kill-buffer () + (interactive) + (message-kill-buffer)) + +;;; _ + +;;;###autoload +(define-mail-user-agent 'notmuch-user-agent + 'notmuch-mua-mail + 'notmuch-mua-send-and-exit + 'notmuch-mua-kill-buffer + 'notmuch-mua-send-hook) + +;; Add some more headers to the list that `message-mode' hides when +;; composing a message. +(notmuch-mua-add-more-hidden-headers) + +(provide 'notmuch-mua) + +;;; notmuch-mua.el ends here blob - /dev/null blob + 710c60e15ec12c7b3f5d6ca02d869d5be45f03d6 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-parser.el @@ -0,0 +1,194 @@ +;;; notmuch-parser.el --- streaming S-expression parser -*- lexical-binding: t -*- +;; +;; Copyright © Austin Clements +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Austin Clements + +;;; Code: + +(require 'cl-lib) +(require 'pcase) +(require 'subr-x) + +(defun notmuch-sexp-create-parser () + "Return a new streaming S-expression parser. + +This parser is designed to incrementally read an S-expression +whose structure is known to the caller. Like a typical +S-expression parsing interface, it provides a function to read a +complete S-expression from the input. However, it extends this +with an additional function that requires the next value in the +input to be a list and descends into it, allowing its elements to +be read one at a time or further descended into. Both functions +can return \\='retry to indicate that not enough input is available. + +The parser always consumes input from point in the current +buffer. Hence, the caller is allowed to delete any data before +point and may resynchronize after an error by moving point." + (vector 'notmuch-sexp-parser + 0 ; List depth + nil ; Partial parse position marker + nil)) ; Partial parse state + +(defmacro notmuch-sexp--depth (sp) `(aref ,sp 1)) +(defmacro notmuch-sexp--partial-pos (sp) `(aref ,sp 2)) +(defmacro notmuch-sexp--partial-state (sp) `(aref ,sp 3)) + +(defun notmuch-sexp-read (sp) + "Consume and return the value at point in the current buffer. + +Returns \\='retry if there is insufficient input to parse a complete +value (though it may still move point over whitespace). If the +parser is currently inside a list and the next token ends the +list, this moves point just past the terminator and returns \\='end. +Otherwise, this moves point to just past the end of the value and +returns the value." + (skip-chars-forward " \n\r\t") + (cond ((eobp) 'retry) + ((= (char-after) ?\)) + ;; We've reached the end of a list + (if (= (notmuch-sexp--depth sp) 0) + ;; .. but we weren't in a list. Let read signal the + ;; error to be consistent with all other code paths. + (read (current-buffer)) + ;; Go up a level and return an end token + (cl-decf (notmuch-sexp--depth sp)) + (forward-char) + 'end)) + ((= (char-after) ?\() + ;; We're at the beginning of a list. If we haven't started + ;; a partial parse yet, attempt to read the list in its + ;; entirety. If this fails, or we've started a partial + ;; parse, extend the partial parse to figure out when we + ;; have a complete list. + (catch 'return + (unless (notmuch-sexp--partial-state sp) + (let ((start (point))) + (condition-case nil + (throw 'return (read (current-buffer))) + (end-of-file (goto-char start))))) + ;; Extend the partial parse + (let (is-complete) + (save-excursion + (let* ((new-state (parse-partial-sexp + (or (notmuch-sexp--partial-pos sp) (point)) + (point-max) 0 nil + (notmuch-sexp--partial-state sp))) + ;; A complete value is available if we've + ;; reached depth 0. + (depth (car new-state))) + (cl-assert (>= depth 0)) + (if (= depth 0) + ;; Reset partial parse state + (setf (notmuch-sexp--partial-state sp) nil + (notmuch-sexp--partial-pos sp) nil + is-complete t) + ;; Update partial parse state + (setf (notmuch-sexp--partial-state sp) new-state + (notmuch-sexp--partial-pos sp) (point-marker))))) + (if is-complete + (read (current-buffer)) + 'retry)))) + (t + ;; Attempt to read a non-compound value + (let ((start (point))) + (condition-case nil + (let ((val (read (current-buffer)))) + ;; We got what looks like a complete read, but if + ;; we reached the end of the buffer in the process, + ;; we may not actually have all of the input we + ;; need (unless it's a string, which is delimited). + (if (or (stringp val) (not (eobp))) + val + ;; We can't be sure the input was complete + (goto-char start) + 'retry)) + (end-of-file + (goto-char start) + 'retry)))))) + +(defun notmuch-sexp-begin-list (sp) + "Parse the beginning of a list value and enter the list. + +Returns \\='retry if there is insufficient input to parse the +beginning of the list. If this is able to parse the beginning of +a list, it moves point past the token that opens the list and +returns t. Later calls to `notmuch-sexp-read' will return the +elements inside the list. If the input in buffer is not the +beginning of a list, throw invalid-read-syntax." + (skip-chars-forward " \n\r\t") + (cond ((eobp) 'retry) + ((= (char-after) ?\() + (forward-char) + (cl-incf (notmuch-sexp--depth sp)) + t) + (t + ;; Skip over the bad character like `read' does + (forward-char) + (signal 'invalid-read-syntax (list (string (char-before))))))) + +(defvar notmuch-sexp--parser nil + "The buffer-local notmuch-sexp-parser instance. + +Used by `notmuch-sexp-parse-partial-list'.") + +(defvar notmuch-sexp--state nil + "The buffer-local `notmuch-sexp-parse-partial-list' state.") + +(defun notmuch-sexp-parse-partial-list (result-function result-buffer) + "Incrementally parse an S-expression list from the current buffer. + +This function consumes an S-expression list from the current +buffer, applying RESULT-FUNCTION in RESULT-BUFFER to each +complete value in the list. It operates incrementally and should +be called whenever the input buffer has been extended with +additional data. The caller just needs to ensure it does not +move point in the input buffer." + ;; Set up the initial state + (unless (local-variable-p 'notmuch-sexp--parser) + (setq-local notmuch-sexp--parser (notmuch-sexp-create-parser)) + (setq-local notmuch-sexp--state 'begin)) + (let (done) + (while (not done) + (cl-case notmuch-sexp--state + (begin + ;; Enter the list + (if (eq (notmuch-sexp-begin-list notmuch-sexp--parser) 'retry) + (setq done t) + (setq notmuch-sexp--state 'result))) + (result + ;; Parse a result + (let ((result (notmuch-sexp-read notmuch-sexp--parser))) + (cl-case result + (retry (setq done t)) + (end (setq notmuch-sexp--state 'end)) + (t (with-current-buffer result-buffer + (funcall result-function result)))))) + (end + ;; Skip over trailing whitespace. + (skip-chars-forward " \n\r\t") + ;; Any trailing data is unexpected. + (unless (eobp) + (error "Trailing garbage following expression")) + (setq done t))))) + ;; Clear out what we've parsed + (delete-region (point-min) (point))) + +(provide 'notmuch-parser) + +;;; notmuch-parser.el ends here blob - /dev/null blob + f008b73d0da3fecaaa2c257e66fa41e5e47861e5 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-pkg.el @@ -0,0 +1,7 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "notmuch" "0.39" + "Run notmuch within emacs." + () + :url "https://notmuchmail.org" + :commit "a5214eabb63ba78b84f4563942de1aa8763f0914" + :revdesc "0.39-0-ga5214eabb63b") blob - /dev/null blob + 8d9f1b0830319c5d2bb2262029334d89b5174a10 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-print.el @@ -0,0 +1,100 @@ +;;; notmuch-print.el --- printing messages from notmuch -*- lexical-binding: t -*- +;; +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Edmondson + +;;; Code: + +(require 'notmuch-lib) + +(declare-function notmuch-show-get-prop "notmuch-show" (prop &optional props)) + +;;; Options + +(defcustom notmuch-print-mechanism 'notmuch-print-lpr + "How should printing be done?" + :group 'notmuch-show + :type '(choice + (function :tag "Use lpr" notmuch-print-lpr) + (function :tag "Use ps-print" notmuch-print-ps-print) + (function :tag "Use ps-print then evince" notmuch-print-ps-print/evince) + (function :tag "Use muttprint" notmuch-print-muttprint) + (function :tag "Use muttprint then evince" notmuch-print-muttprint/evince) + (function :tag "Using a custom function"))) + +;;; Utility functions + +(defun notmuch-print-run-evince (file) + "View FILE using `evince'." + (start-process "evince" nil "evince" file)) + +(defun notmuch-print-run-muttprint (&optional output) + "Pass the contents of the current buffer to `muttprint'. + +Optional OUTPUT allows passing a list of flags to muttprint." + (apply #'notmuch--call-process-region (point-min) (point-max) + ;; Reads from stdin. + "muttprint" + nil nil nil + ;; Show the tags. + "--printed-headers" "Date_To_From_CC_Newsgroups_*Subject*_/Tags/" + output)) + +;;; User-visible functions + +(defun notmuch-print-lpr (_msg) + "Print a message buffer using lpr." + (lpr-buffer)) + +(defun notmuch-print-ps-print (msg) + "Print a message buffer using the ps-print package." + (let ((subject (notmuch-prettify-subject + (plist-get (notmuch-show-get-prop :headers msg) :Subject)))) + (rename-buffer subject t) + (ps-print-buffer))) + +(defun notmuch-print-ps-print/evince (msg) + "Preview a message buffer using ps-print and evince." + (let ((ps-file (make-temp-file "notmuch" nil ".ps")) + (subject (notmuch-prettify-subject + (plist-get (notmuch-show-get-prop :headers msg) :Subject)))) + (rename-buffer subject t) + (ps-print-buffer ps-file) + (notmuch-print-run-evince ps-file))) + +(defun notmuch-print-muttprint (_msg) + "Print a message using muttprint." + (notmuch-print-run-muttprint)) + +(defun notmuch-print-muttprint/evince (_msg) + "Preview a message buffer using muttprint and evince." + (let ((ps-file (make-temp-file "notmuch" nil ".ps"))) + (notmuch-print-run-muttprint (list "--printer" (concat "TO_FILE:" ps-file))) + (notmuch-print-run-evince ps-file))) + +(defun notmuch-print-message (msg) + "Print a message using the user-selected mechanism." + (set-buffer-modified-p nil) + (funcall notmuch-print-mechanism msg)) + +;;; _ + +(provide 'notmuch-print) + +;;; notmuch-print.el ends here blob - /dev/null blob + 2a46144c49846dcf3301ac5b365951fcab731239 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-query.el @@ -0,0 +1,74 @@ +;;; notmuch-query.el --- provide an emacs api to query notmuch -*- lexical-binding: t -*- +;; +;; Copyright © David Bremner +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Bremner + +;;; Code: + +(require 'notmuch-lib) + +;;; Basic query function + +(define-obsolete-function-alias + 'notmuch-query-get-threads + #'notmuch--run-show + "notmuch 0.37") + +;;; Mapping functions across collections of messages + +(defun notmuch-query-map-aux (mapper function seq) + "Private function to do the actual mapping and flattening." + (cl-mapcan (lambda (tree) + (funcall mapper function tree)) + seq)) + +(defun notmuch-query-map-threads (fn threads) + "Apply function FN to every thread in THREADS. +Flatten results to a list. See the function +`notmuch-query-get-threads' for more information." + (notmuch-query-map-aux 'notmuch-query-map-forest fn threads)) + +(defun notmuch-query-map-forest (fn forest) + "Apply function FN to every message in FOREST. +Flatten results to a list. See the function +`notmuch-query-get-threads' for more information." + (notmuch-query-map-aux 'notmuch-query-map-tree fn forest)) + +(defun notmuch-query-map-tree (fn tree) + "Apply function FN to every message in TREE. +Flatten results to a list. See the function +`notmuch--run-show' for more information." + (cons (funcall fn (car tree)) + (notmuch-query-map-forest fn (cadr tree)))) + +;;; Predefined queries + +(defun notmuch-query-get-message-ids (&rest search-terms) + "Return a list of message-ids of messages that match SEARCH-TERMS." + (notmuch-query-map-threads + (lambda (msg) (plist-get msg :id)) + (notmuch--run-show search-terms))) + +;;; Everything in this library is obsolete +(dolist (fun '(map-aux map-threads map-forest map-tree get-message-ids)) + (make-obsolete (intern (format "notmuch-query-%s" fun)) nil "notmuch 0.37")) + +(provide 'notmuch-query) + +;;; notmuch-query.el ends here blob - /dev/null blob + 8a8e6a7b00eaf3d5b65e472c920122fd8aa9d784 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-show.el @@ -0,0 +1,2741 @@ +;;; notmuch-show.el --- displaying notmuch forests -*- lexical-binding: t -*- +;; +;; Copyright © Carl Worth +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; David Edmondson + +;;; Code: + +(require 'mm-view) +(require 'message) +(require 'mm-decode) +(require 'mailcap) +(require 'icalendar) +(require 'goto-addr) + +(require 'notmuch-lib) +(require 'notmuch-tag) +(require 'notmuch-wash) +(require 'notmuch-mua) +(require 'notmuch-crypto) +(require 'notmuch-print) +(require 'notmuch-draft) + +(declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args)) +(declare-function notmuch-search-next-thread "notmuch" nil) +(declare-function notmuch-search-previous-thread "notmuch" nil) +(declare-function notmuch-search-show-thread "notmuch") +(declare-function notmuch-foreach-mime-part "notmuch" (function mm-handle)) +(declare-function notmuch-count-attachments "notmuch" (mm-handle)) +(declare-function notmuch-save-attachments "notmuch" (mm-handle &optional queryp)) +(declare-function notmuch-tree "notmuch-tree" + (&optional query query-context target buffer-name + open-target unthreaded parent-buffer)) +(declare-function notmuch-tree-get-message-properties "notmuch-tree" nil) +(declare-function notmuch-unthreaded "notmuch-tree" + (&optional query query-context target buffer-name + open-target)) +(declare-function notmuch-read-query "notmuch" (prompt)) +(declare-function notmuch-draft-resume "notmuch-draft" (id)) + +(defvar shr-blocked-images) +(defvar gnus-blocked-images) +(defvar shr-content-function) +(defvar w3m-ignored-image-url-regexp) + +;;; Options + +(defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") + "Headers that should be shown in a message, in this order. + +For an open message, all of these headers will be made visible +according to `notmuch-message-headers-visible' or can be toggled +with `notmuch-show-toggle-visibility-headers'. For a closed message, +only the first header in the list will be visible." + :type '(repeat string) + :group 'notmuch-show) + +(defcustom notmuch-message-headers-visible t + "Should the headers be visible by default? + +If this value is non-nil, then all of the headers defined in +`notmuch-message-headers' will be visible by default in the display +of each message. Otherwise, these headers will be hidden and +`notmuch-show-toggle-visibility-headers' can be used to make them +visible for any given message." + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-header-line t + "Show a header line in notmuch show buffers. + +If t (the default), the header line will contain the current +message's subject. + +If a string, this value is interpreted as a format string to be +passed to `format-spec` with `%s` as the substitution variable +for the message's subject. E.g., to display the subject trimmed +to a maximum of 80 columns, you could use \"%>-80s\" as format. + +If you assign to this variable a function, it will be called with +the subject as argument, and the return value will be used as the +header line format. Since the function is called with the +message buffer as the current buffer, it is also possible to +access any other properties of the message, using for instance +notmuch-show functions such as +`notmuch-show-get-message-properties'. + +Finally, if this variable is set to nil, no header is +displayed." + :type '(choice (const :tag "No header" ni) + (const :tag "Subject" t) + (string :tag "Format") + (function :tag "Function")) + :group 'notmuch-show) + +(defcustom notmuch-show-depth-limit nil + "Depth beyond which message bodies are displayed lazily. + +If bound to an integer, any message with tree depth greater than +this will have its body display lazily, initially +inserting only a button. + +If this variable is set to nil (the default) no such lazy +insertion is done." + :type '(choice (const :tag "No limit" nil) + (number :tag "Limit" 10)) + :group 'notmuch-show) + +(defcustom notmuch-show-height-limit nil + "Height (from leaves) beyond which message bodies are displayed lazily. + +If bound to an integer, any message with height in the message +tree greater than this will have its body displayed lazily, +initially only a button. + +If this variable is set to nil (the default) no such lazy +display is done." + :type '(choice (const :tag "No limit" nil) + (number :tag "Limit" 10)) + :group 'notmuch-show) + +(defcustom notmuch-show-relative-dates t + "Display relative dates in the message summary line." + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers) + "A list of functions called to decorate the headers listed in +`notmuch-message-headers'.") + +(defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode) + "Functions called after populating a `notmuch-show' buffer." + :type 'hook + :options '(notmuch-show-turn-on-visual-line-mode) + :group 'notmuch-show + :group 'notmuch-hooks) + +(defcustom notmuch-show-insert-text/plain-hook + '(notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + "Functions used to improve the display of text/plain parts." + :type 'hook + :options '(notmuch-wash-convert-inline-patch-to-part + notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + :group 'notmuch-show + :group 'notmuch-hooks) + +(defcustom notmuch-show-max-text-part-size 100000 + "Maximum size of a text part to be shown by default in characters. + +Set to 0 to show the part regardless of size." + :type 'integer + :group 'notmuch-show) + +;; Mostly useful for debugging. +(defcustom notmuch-show-all-multipart/alternative-parts nil + "Should all parts of multipart/alternative parts be shown?" + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-indent-messages-width 1 + "Width of message indentation in threads. + +Messages are shown indented according to their depth in a thread. +This variable determines the width of this indentation measured +in number of blanks. Defaults to `1', choose `0' to disable +indentation." + :type 'integer + :group 'notmuch-show) + +(defcustom notmuch-show-indent-multipart nil + "Should the sub-parts of a multipart/* part be indented?" + ;; dme: Not sure which is a good default. + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part + "Default part header button action (on ENTER or mouse click)." + :group 'notmuch-show + :type '(choice (const :tag "Save part" + notmuch-show-save-part) + (const :tag "View part" + notmuch-show-view-part) + (const :tag "View interactively" + notmuch-show-interactively-view-part))) + +(defcustom notmuch-show-only-matching-messages nil + "Only matching messages are shown by default." + :type 'boolean + :group 'notmuch-show) + +;; By default, block all external images to prevent privacy leaks and +;; potential attacks. +(defcustom notmuch-show-text/html-blocked-images "." + "Remote images that have URLs matching this regexp will be blocked." + :type '(choice (const nil) regexp) + :group 'notmuch-show) + +;;; Variables + +(defvar-local notmuch-show-thread-id nil) + +(defvar-local notmuch-show-parent-buffer nil) + +(defvar-local notmuch-show-query-context nil) + +(defvar-local notmuch-show-process-crypto nil) + +(defvar-local notmuch-show-elide-non-matching-messages nil) + +(defvar-local notmuch-show-indent-content t) + +(defvar-local notmuch-show-single-message nil) + +(defvar notmuch-show-attachment-debug nil + "If t log stdout and stderr from attachment handlers. + +When set to nil (the default) stdout and stderr from attachment +handlers is discarded. When set to t the stdout and stderr from +each attachment handler is logged in buffers with names beginning +\" *notmuch-part*\".") + +;;; Options + +(defcustom notmuch-show-stash-mlarchive-link-alist + '(("MARC" . "https://marc.info/?i=") + ("Mail Archive, The" . "https://mid.mail-archive.com/") + ("Lore" . "https://lore.kernel.org/r/") + ("Notmuch" . "https://nmbug.notmuchmail.org/nmweb/show/") + ;; FIXME: can these services be searched by `Message-Id' ? + ;; ("MarkMail" . "http://markmail.org/") + ;; ("Nabble" . "http://nabble.com/") + ;; ("opensubscriber" . "http://opensubscriber.com/") + ) + "List of Mailing List Archives to use when stashing links. + +This list is used for generating a Mailing List Archive reference +URI with the current message's Message-Id in +`notmuch-show-stash-mlarchive-link'. + +If the cdr of the alist element is not a function, the cdr is +expected to contain a URI that is concatenated with the current +message's Message-Id to create a ML archive reference URI. + +If the cdr is a function, the function is called with the +Message-Id as the argument, and the function is expected to +return the ML archive reference URI." + :type '(alist :key-type (string :tag "Name") + :value-type (choice + (string :tag "URL") + (function :tag "Function returning the URL"))) + :group 'notmuch-show) + +(defcustom notmuch-show-stash-mlarchive-link-default "MARC" + "Default Mailing List Archive to use when stashing links. + +This is used when `notmuch-show-stash-mlarchive-link' isn't +provided with an MLA argument nor `completing-read' input." + :type `(choice + ,@(mapcar + (lambda (mla) + (list 'const :tag (car mla) :value (car mla))) + notmuch-show-stash-mlarchive-link-alist)) + :group 'notmuch-show) + +(defcustom notmuch-show-mark-read-tags '("-unread") + "List of tag changes to apply to a message when it is marked as read. + +Tags starting with \"+\" (or not starting with either \"+\" or +\"-\") in the list will be added, and tags starting with \"-\" +will be removed from the message being marked as read. + +For example, if you wanted to remove an \"unread\" tag and add a +\"read\" tag (which would make little sense), you would set: + (\"-unread\" \"+read\")" + :type '(repeat string) + :group 'notmuch-show) + +(defcustom notmuch-show-mark-read-function #'notmuch-show-seen-current-message + "Function to control which messages are marked read. + +The function should take two arguments START and END which will +be the start and end of the visible portion of the buffer and +should mark the appropriate messages read by applying +`notmuch-show-mark-read'. This function will be called after +every user interaction with notmuch." + :type 'function + :group 'notmuch-show) + +(defcustom notmuch-show-imenu-indent nil + "Should Imenu display messages indented. + +By default, Imenu (see Info node `(emacs) Imenu') in a +notmuch-show buffer displays all messages straight. This is +because the default Emacs frontend for Imenu makes it difficult +to select an Imenu entry with spaces in front. Other imenu +frontends such as counsel-imenu does not have this limitation. +In these cases, Imenu entries can be indented to reflect the +position of the message in the thread." + :type 'boolean + :group 'notmuch-show) + +;;; Utilities + +(defmacro with-current-notmuch-show-message (&rest body) + "Evaluate body with current buffer set to the text of current message." + `(save-excursion + (let ((id (notmuch-show-get-message-id))) + (let ((buf (generate-new-buffer (concat "*notmuch-msg-" id "*")))) + (with-current-buffer buf + (let ((coding-system-for-read 'no-conversion)) + (notmuch--call-process notmuch-command nil t nil "show" "--format=raw" id)) + ,@body) + (kill-buffer buf))))) + +(defun notmuch-show-turn-on-visual-line-mode () + "Enable Visual Line mode." + (visual-line-mode t)) + +;;; Commands + +;; DEPRECATED in Notmuch 0.16 since we now have convenient part +;; commands. We'll keep the command around for a version or two in +;; case people want to bind it themselves. +(defun notmuch-show-view-all-mime-parts () + "Use external viewers to view all attachments from the current message." + (interactive) + (with-current-notmuch-show-message + ;; We override the mm-inline-media-tests to indicate which message + ;; parts are already sufficiently handled by the original + ;; presentation of the message in notmuch-show mode. These parts + ;; will be inserted directly into the temporary buffer of + ;; with-current-notmuch-show-message and silently discarded. + ;; + ;; Any MIME part not explicitly mentioned here will be handled by an + ;; external viewer as configured in the various mailcap files. + (let ((mm-inline-media-tests + '(("text/.*" ignore identity) + ("application/pgp-signature" ignore identity) + ("multipart/alternative" ignore identity) + ("multipart/mixed" ignore identity) + ("multipart/related" ignore identity)))) + (mm-display-parts (mm-dissect-buffer))))) + +(defun notmuch-show-save-attachments () + "Save all attachments from the current message." + (interactive) + (with-current-notmuch-show-message + (let ((mm-handle (mm-dissect-buffer))) + (notmuch-save-attachments + mm-handle (> (notmuch-count-attachments mm-handle) 1)))) + (message "Done")) + +(defun notmuch-show-with-message-as-text (fn) + "Apply FN to a text representation of the current message. + +FN is called with one argument, the message properties. It should +operation on the contents of the current buffer." + ;; Remake the header to ensure that all information is available. + (let* ((to (notmuch-show-get-to)) + (cc (notmuch-show-get-cc)) + (from (notmuch-show-get-from)) + (subject (notmuch-show-get-subject)) + (date (notmuch-show-get-date)) + (tags (notmuch-show-get-tags)) + (depth (notmuch-show-get-depth)) + (header (concat + "Subject: " subject "\n" + "To: " to "\n" + (if (not (string-empty-p cc)) + (concat "Cc: " cc "\n") + "") + "From: " from "\n" + "Date: " date "\n" + (if tags + (concat "Tags: " + (mapconcat #'identity tags ", ") "\n") + ""))) + (all (buffer-substring (notmuch-show-message-top) + (notmuch-show-message-bottom))) + + (props (notmuch-show-get-message-properties)) + (indenting notmuch-show-indent-content)) + (with-temp-buffer + (insert all) + (when indenting + (indent-rigidly (point-min) + (point-max) + (- (* notmuch-show-indent-messages-width depth)))) + ;; Remove the original header. + (goto-char (point-min)) + (re-search-forward "^$" (point-max) nil) + (delete-region (point-min) (point)) + (insert header) + (funcall fn props)))) + +(defun notmuch-show-print-message () + "Print the current message." + (interactive) + (notmuch-show-with-message-as-text 'notmuch-print-message)) + +;;; Headers + +(defun notmuch-show-fontify-header () + (let ((face (cond + ((looking-at "[Tt]o:") + 'message-header-to) + ((looking-at "[Bb]?[Cc][Cc]:") + 'message-header-cc) + ((looking-at "[Ss]ubject:") + 'message-header-subject) + (t + 'message-header-other)))) + (overlay-put (make-overlay (point) (re-search-forward ":")) + 'face 'message-header-name) + (overlay-put (make-overlay (point) (re-search-forward ".*$")) + 'face face))) + +(defun notmuch-show-colour-headers () + "Apply some colouring to the current headers." + (goto-char (point-min)) + (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:") + (notmuch-show-fontify-header) + (forward-line))) + +(defun notmuch-show-spaces-n (n) + "Return a string comprised of `n' spaces." + (make-string n ? )) + +(defun notmuch-show-update-tags (tags) + "Update the displayed tags of the current message." + (save-excursion + (let ((inhibit-read-only t) + (start (notmuch-show-message-top)) + (depth (notmuch-show-get-prop :depth)) + (orig-tags (notmuch-show-get-prop :orig-tags)) + (props (notmuch-show-get-message-properties)) + (extent (notmuch-show-message-extent))) + (goto-char start) + (notmuch-show-insert-headerline props depth tags orig-tags) + (put-text-property start (1+ start) + :notmuch-message-properties props) + (put-text-property (car extent) (cdr extent) :notmuch-message-extent extent) + ;; delete original headerline, but do not save to kill ring + (delete-region (point) (1+ (line-end-position)))))) + +(defun notmuch-clean-address (address) + "Try to clean a single email ADDRESS for display. Return a cons +cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if +parsing fails." + (condition-case nil + (let (p-name p-address) + ;; It would be convenient to use `mail-header-parse-address', + ;; but that expects un-decoded mailbox parts, whereas our + ;; mailbox parts are already decoded (and hence may contain + ;; UTF-8). Given that notmuch should handle most of the awkward + ;; cases, some simple string deconstruction should be sufficient + ;; here. + (cond + ;; "User " style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address)) + (setq p-address (match-string 2 address))) + + ;; "" style. + ((string-match "<\\(.*\\)>" address) + (setq p-address (match-string 1 address))) + ;; Everything else. + (t + (setq p-address address))) + (when p-name + ;; Remove elements of the mailbox part that are not relevant for + ;; display, even if they are required during transport: + ;; + ;; Backslashes. + (setq p-name (replace-regexp-in-string "\\\\" "" p-name)) + ;; Outer single and double quotes, which might be nested. + (cl-loop with start-of-loop + do (setq start-of-loop p-name) + when (string-match "^\"\\(.*\\)\"$" p-name) + do (setq p-name (match-string 1 p-name)) + when (string-match "^'\\(.*\\)'$" p-name) + do (setq p-name (match-string 1 p-name)) + until (string= start-of-loop p-name))) + ;; If the address is 'foo@bar.com ' then show just + ;; 'foo@bar.com'. + (when (string= p-name p-address) + (setq p-name nil)) + (cons p-address p-name)) + (error (cons address nil)))) + +(defun notmuch-show-clean-address (address) + "Try to clean a single email ADDRESS for display. +Return unchanged ADDRESS if parsing fails." + (let* ((clean-address (notmuch-clean-address address)) + (p-address (car clean-address)) + (p-name (cdr clean-address))) + ;; If no name, return just the address. + (if (not p-name) + p-address + ;; Otherwise format the name and address together. + (concat p-name " <" p-address ">")))) + +(defun notmuch-show--mark-height (tree) + "Calculate and cache height (distance from deepest descendent)" + (let* ((msg (car tree)) + (children (cadr tree)) + (cached-height (plist-get msg :height))) + (or cached-height + (let ((height + (if (null children) 0 + (1+ (apply #'max (mapcar #'notmuch-show--mark-height children)))))) + (plist-put msg :height height) + height)))) + +(defun notmuch-show-insert-headerline (msg-plist depth tags &optional orig-tags) + "Insert a notmuch style headerline based on HEADERS for a +message at DEPTH in the current thread." + (let* ((start (point)) + (headers (plist-get msg-plist :headers)) + (duplicate (or (plist-get msg-plist :duplicate) 0)) + (file-count (length (plist-get msg-plist :filename))) + (date (or (and notmuch-show-relative-dates + (plist-get msg-plist :date_relative)) + (plist-get headers :Date))) + (from (notmuch-sanitize + (notmuch-show-clean-address (plist-get headers :From))))) + (when (string-match "\\cR" from) + ;; If the From header has a right-to-left character add + ;; invisible U+200E LEFT-TO-RIGHT MARK character which forces + ;; the header paragraph as left-to-right text. + (insert (propertize (string ?\x200e) 'invisible t))) + (insert (if notmuch-show-indent-content + (notmuch-show-spaces-n (* notmuch-show-indent-messages-width + depth)) + "") + from + " (" + date + ") (" + (notmuch-tag-format-tags tags (or orig-tags tags)) + ")") + (insert + (if (> file-count 1) + (let ((txt (format "%d/%d\n" duplicate file-count))) + (concat + (notmuch-show-spaces-n (max 0 (- (window-width) (+ (current-column) (length txt))))) + txt)) + "\n")) + (overlay-put (make-overlay start (point)) + 'face 'notmuch-message-summary-face))) + +(defun notmuch-show-insert-header (header header-value) + "Insert a single header." + (insert header ": " (notmuch-sanitize header-value) "\n")) + +(defun notmuch-show-insert-headers (headers) + "Insert the headers of the current message." + (let ((start (point))) + (mapc (lambda (header) + (let* ((header-symbol (intern (concat ":" header))) + (header-value (plist-get headers header-symbol))) + (when (and header-value + (not (string-equal "" header-value))) + (notmuch-show-insert-header header header-value)))) + notmuch-message-headers) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hooks 'notmuch-show-markup-headers-hook))))) + +;;; Parts + +(define-button-type 'notmuch-show-part-button-type + 'action 'notmuch-show-part-button-default + 'follow-link t + 'face 'message-mml + :supertype 'notmuch-button-type) + +(defun notmuch-show-insert-part-header (_nth content-type declared-type + &optional name comment) + (let ((base-label (concat (and name (concat name ": ")) + declared-type + (and (not (string-equal declared-type content-type)) + (concat " (as " content-type ")")) + comment))) + (prog1 (insert-button + (concat "[ " base-label " ]") + :base-label base-label + :type 'notmuch-show-part-button-type + :notmuch-part-hidden nil) + (insert "\n")))) + +(defun notmuch-show-toggle-part-invisibility (&optional button) + (interactive) + (let ((button (or button (button-at (point))))) + (when button + (let ((overlay (button-get button 'overlay)) + (lazy-part (button-get button :notmuch-lazy-part))) + ;; We have a part to toggle if there is an overlay or if there + ;; is a lazy part. If neither is present we cannot toggle the + ;; part so we just return nil. + (when (or overlay lazy-part) + (let* ((show (button-get button :notmuch-part-hidden)) + (new-start (button-start button)) + (button-label (button-get button :base-label)) + (old-point (point)) + (properties (text-properties-at (button-start button))) + (inhibit-read-only t)) + ;; Toggle the button itself. + (button-put button :notmuch-part-hidden (not show)) + (goto-char new-start) + (insert "[ " button-label (if show " ]" " (hidden) ]")) + (set-text-properties new-start (point) properties) + (let ((old-end (button-end button))) + (move-overlay button new-start (point)) + (delete-region (point) old-end)) + (goto-char (min old-point (1- (button-end button)))) + ;; Return nil if there is a lazy-part, it is empty, and we are + ;; trying to show it. In all other cases return t. + (if lazy-part + (when show + (button-put button :notmuch-lazy-part nil) + (notmuch-show-lazy-part lazy-part button)) + (let* ((part (plist-get properties :notmuch-part)) + (undisplayer (plist-get part :undisplayer)) + (mime-type (plist-get part :computed-type)) + (redisplay-data (button-get button + :notmuch-redisplay-data)) + (imagep (string-match "^image/" mime-type))) + (cond + ((and imagep (not show) undisplayer) + ;; call undisplayer thunk created by gnus. + (funcall undisplayer) + ;; there is an extra newline left + (delete-region + (+ 1 (button-end button)) + (+ 2 (button-end button)))) + ((and imagep show redisplay-data) + (notmuch-show-lazy-part redisplay-data button)) + (t + (overlay-put overlay 'invisible (not show))))) + t))))))) + +;;; Part content ID handling + +(defvar notmuch-show--cids nil + "Alist from raw content ID to (MSG PART).") +(make-variable-buffer-local 'notmuch-show--cids) + +(defun notmuch-show--register-cids (msg part) + "Register content-IDs in PART and all of PART's sub-parts." + (let ((content-id (plist-get part :content-id))) + (when content-id + ;; Note that content-IDs are globally unique, except when they + ;; aren't: RFC 2046 section 5.1.4 permits children of a + ;; multipart/alternative to have the same content-ID, in which + ;; case the MUA is supposed to pick the best one it can render. + ;; We simply add the content-ID to the beginning of our alist; + ;; so if this happens, we'll take the last (and "best") + ;; alternative (even if we can't render it). + (push (list content-id msg part) notmuch-show--cids))) + ;; Recurse on sub-parts + (when-let ((type (plist-get part :content-type))) + (pcase-let ((`(,type ,subtype) + (split-string (downcase type) "/"))) + (cond ((equal type "multipart") + (mapc (apply-partially #'notmuch-show--register-cids msg) + (plist-get part :content))) + ((and (equal type "message") + (equal subtype "rfc822")) + (notmuch-show--register-cids + msg + (car (plist-get (car (plist-get part :content)) :body)))))))) + +(defun notmuch-show--get-cid-content (cid) + "Return a list (CID-content content-type) or nil. + +This will only find parts from messages that have been inserted +into the current buffer. CID must be a raw content ID, without +enclosing angle brackets, a cid: prefix, or URL encoding. This +will return nil if the CID is unknown or cannot be retrieved." + (when-let ((descriptor (cdr (assoc cid notmuch-show--cids)))) + (pcase-let ((`(,msg ,part) descriptor)) + ;; Request caching for this content, as some messages + ;; reference the same cid: part many times (hundreds!). + (list (notmuch-get-bodypart-binary + msg part notmuch-show-process-crypto 'cache) + (plist-get part :content-type))))) + +(defun notmuch-show-setup-w3m () + "Instruct w3m how to retrieve content from a \"related\" part of a message." + (interactive) + (when (and (boundp 'w3m-cid-retrieve-function-alist) + (not (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist))) + (push (cons 'notmuch-show-mode #'notmuch-show--cid-w3m-retrieve) + w3m-cid-retrieve-function-alist)) + (setq mm-html-inhibit-images nil)) + +(defvar w3m-current-buffer) ;; From `w3m.el'. +(defun notmuch-show--cid-w3m-retrieve (url &rest _args) + ;; url includes the cid: prefix and is URL encoded (see RFC 2392). + (let* ((cid (url-unhex-string (substring url 4))) + (content-and-type + (with-current-buffer w3m-current-buffer + (notmuch-show--get-cid-content cid)))) + (when content-and-type + (insert (car content-and-type)) + (cadr content-and-type)))) + +;; MIME part renderers + +(defun notmuch-show-multipart/*-to-list (part) + (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) + (plist-get part :content))) + +(defun notmuch-show-insert-part-multipart/alternative (msg part _content-type _nth depth _button) + (let ((chosen-type (car (notmuch-multipart/alternative-choose + msg (notmuch-show-multipart/*-to-list part)))) + (inner-parts (plist-get part :content)) + (start (point))) + ;; This inserts all parts of the chosen type rather than just one, + ;; but it's not clear that this is the wrong thing to do - which + ;; should be chosen if there are more than one that match? + (mapc (lambda (inner-part) + (let* ((inner-type (plist-get inner-part :content-type)) + (hide (not (or notmuch-show-all-multipart/alternative-parts + (string= chosen-type inner-type))))) + (notmuch-show-insert-bodypart msg inner-part depth hide))) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/related (msg part _content-type _nth depth _button) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Render the primary part. FIXME: Support RFC 2387 Start header. + (notmuch-show-insert-bodypart msg (car inner-parts) depth) + ;; Add hidden buttons for the rest + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth t)) + (cdr inner-parts)) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/signed (msg part _content-type _nth depth button) + (when button + (button-put button 'face 'notmuch-crypto-part-header)) + ;; Insert a button detailing the signature status. + (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus)) + (notmuch-show-get-header :From msg)) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/encrypted (msg part _content-type _nth depth button) + (when button + (button-put button 'face 'notmuch-crypto-part-header)) + ;; Insert a button detailing the encryption status. + (notmuch-crypto-insert-encstatus-button (car (plist-get part :encstatus))) + ;; Insert a button detailing the signature status. + (notmuch-crypto-insert-sigstatus-button (car (plist-get part :sigstatus)) + (notmuch-show-get-header :From msg)) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-application/pgp-encrypted (_msg _part _content-type _nth _depth _button) + t) + +(defun notmuch-show-insert-part-multipart/* (msg part _content-type _nth depth _button) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-message/rfc822 (msg part _content-type _nth depth _button) + (let ((message (car (plist-get part :content)))) + (and + message + (let ((body (car (plist-get message :body))) + (start (point))) + ;; Override `notmuch-message-headers' to force `From' to be + ;; displayed. + (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) + (notmuch-show-insert-headers (plist-get message :headers))) + ;; Blank line after headers to be compatible with the normal + ;; message display. + (insert "\n") + ;; Show the body + (notmuch-show-insert-bodypart msg body depth) + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1)) + t)))) + +(defun notmuch-show-insert-part-text/plain (msg part _content-type _nth depth button) + ;; For backward compatibility we want to apply the text/plain hook + ;; to the whole of the part including the part button if there is + ;; one. + (let ((start (if button + (button-start button) + (point)))) + (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto)) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth)))) + t) + +(defun notmuch-show-insert-part-text/calendar (msg part _content-type _nth _depth _button) + (insert (with-temp-buffer + (insert (notmuch-get-bodypart-text msg part notmuch-show-process-crypto)) + ;; notmuch-get-bodypart-text does no newline conversion. + ;; Replace CRLF with LF before icalendar can use it. + (goto-char (point-min)) + (while (re-search-forward "\r\n" nil t) + (replace-match "\n" nil nil)) + (let ((file (make-temp-file "notmuch-ical")) + result) + (unwind-protect + (progn + (unless (icalendar-import-buffer file t) + (error "Icalendar import error. %s" + "See *icalendar-errors* for more information")) + (set-buffer (find-buffer-visiting file)) + (setq result (buffer-substring (point-min) (point-max))) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file file)) + result))) + t) + +;; For backwards compatibility. +(defun notmuch-show-insert-part-text/x-vcalendar (msg part _content-type _nth depth _button) + (notmuch-show-insert-part-text/calendar msg part nil nil depth nil)) + +(when (version< emacs-version "25.3") + ;; https://bugs.gnu.org/28350 + ;; + ;; For newer emacs, we fall back to notmuch-show-insert-part-*/* + ;; (see notmuch-show-handlers-for) + (defun notmuch-show-insert-part-text/enriched + (msg part content-type nth depth button) + ;; By requiring enriched below, we ensure that the function + ;; enriched-decode-display-prop is defined before it will be + ;; shadowed by the letf below. Otherwise the version in + ;; enriched.el may be loaded a bit later and used instead (for + ;; the first time). + (require 'enriched) + (cl-letf (((symbol-function 'enriched-decode-display-prop) + (lambda (start end &optional _param) (list start end)))) + (notmuch-show-insert-part-*/* msg part content-type nth depth button)))) + +(defun notmuch-show-get-mime-type-of-application/octet-stream (part) + ;; If we can deduce a MIME type from the filename of the attachment, + ;; we return that. + (and (plist-get part :filename) + (let ((extension (file-name-extension (plist-get part :filename)))) + (and extension + (progn + (mailcap-parse-mimetypes) + (let ((mime-type (mailcap-extension-to-mime extension))) + (and mime-type + (not (string-equal mime-type "application/octet-stream")) + mime-type))))))) + +(defun notmuch-show-insert-part-text/html (msg part content-type nth depth button) + (if (eq mm-text-html-renderer 'shr) + ;; It's easier to drive shr ourselves than to work around the + ;; goofy things `mm-shr' does (like irreversibly taking over + ;; content ID handling). + ;; FIXME: If we block an image, offer a button to load external + ;; images. + (let ((shr-blocked-images notmuch-show-text/html-blocked-images)) + (notmuch-show--insert-part-text/html-shr msg part)) + ;; Otherwise, let message-mode do the heavy lifting + ;; + ;; w3m sets up a keymap which "leaks" outside the invisible region + ;; and causes strange effects in notmuch. We set + ;; mm-inline-text-html-with-w3m-keymap to nil to tell w3m not to + ;; set a keymap (so the normal notmuch-show-mode-map remains). + (let ((mm-inline-text-html-with-w3m-keymap nil) + ;; FIXME: If we block an image, offer a button to load external + ;; images. + (gnus-blocked-images notmuch-show-text/html-blocked-images) + (w3m-ignored-image-url-regexp notmuch-show-text/html-blocked-images)) + (notmuch-show-insert-part-*/* msg part content-type nth depth button)))) + +;;; Functions used by notmuch-show--insert-part-text/html-shr + +(declare-function libxml-parse-html-region "xml.c") +(declare-function shr-insert-document "shr") + +(defun notmuch-show--insert-part-text/html-shr (msg part) + ;; Make sure shr is loaded before we start let-binding its globals + (require 'shr) + (let ((dom (let ((process-crypto notmuch-show-process-crypto)) + (with-temp-buffer + (insert (notmuch-get-bodypart-text msg part process-crypto)) + (libxml-parse-html-region (point-min) (point-max))))) + (shr-content-function + (lambda (url) + ;; shr strips the "cid:" part of URL, but doesn't + ;; URL-decode it (see RFC 2392). + (let ((cid (url-unhex-string url))) + (car (notmuch-show--get-cid-content cid)))))) + (shr-insert-document dom) + t)) + +(defun notmuch-show-insert-part-*/* (msg part content-type _nth _depth _button) + ;; This handler _must_ succeed - it is the handler of last resort. + (notmuch-mm-display-part-inline msg part content-type notmuch-show-process-crypto) + t) + +;;; Functions for determining how to handle MIME parts. + +(defun notmuch-show-handlers-for (content-type) + "Return a list of content handlers for a part of type CONTENT-TYPE." + (let (result) + (mapc (lambda (func) + (when (functionp func) + (push func result))) + ;; Reverse order of prefrence. + (list (intern (concat "notmuch-show-insert-part-*/*")) + (intern (concat "notmuch-show-insert-part-" + (car (split-string content-type "/")) + "/*")) + (intern (concat "notmuch-show-insert-part-" content-type)))) + result)) + +;;; Parts + +(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth button) + ;; Run the handlers until one of them succeeds. + (cl-loop for handler in (notmuch-show-handlers-for content-type) + until (condition-case err + (funcall handler msg part content-type nth depth button) + ;; Specifying `debug' here lets the debugger run if + ;; `debug-on-error' is non-nil. + ((debug error) + (insert "!!! Bodypart handler `" (prin1-to-string handler) + "' threw an error:\n" + "!!! " (error-message-string err) "\n") + nil)))) + +(defun notmuch-show-create-part-overlays (button beg end) + "Add an overlay to the part between BEG and END." + ;; If there is no button (i.e., the part is text/plain and the first + ;; part) or if the part has no content then we don't make the part + ;; toggleable. + (when (and button (/= beg end)) + (button-put button 'overlay (make-overlay beg end)) + ;; Return true if we created an overlay. + t)) + +(defun notmuch-show-record-part-information (part beg end) + "Store PART as a text property from BEG to END." + ;; Record part information. Since we already inserted subparts, + ;; don't override existing :notmuch-part properties. + (notmuch-map-text-property beg end :notmuch-part + (lambda (v) (or v part))) + ;; Make :notmuch-part front sticky and rear non-sticky so it stays + ;; applied to the beginning of each line when we indent the + ;; message. Since we're operating on arbitrary renderer output, + ;; watch out for sticky specs of t, which means all properties are + ;; front-sticky/rear-nonsticky. + (notmuch-map-text-property beg end 'front-sticky + (lambda (v) + (if (listp v) + (cl-pushnew :notmuch-part v) + v))) + (notmuch-map-text-property beg end 'rear-nonsticky + (lambda (v) + (if (listp v) + (cl-pushnew :notmuch-part v) + v)))) + +(defun notmuch-show-lazy-part (part-args button) + ;; Insert the lazy part after the button for the part. We would just + ;; move to the start of the new line following the button and insert + ;; the part but that point might have text properties (eg colours + ;; from a message header etc) so instead we start from the last + ;; character of the button by adding a newline and finish by + ;; removing the extra newline from the end of the part. + (save-excursion + (goto-char (button-end button)) + (insert "\n") + (let* ((inhibit-read-only t) + ;; We need to use markers for the start and end of the part + ;; because the part insertion functions do not guarantee + ;; to leave point at the end of the part. + (part-beg (copy-marker (point) nil)) + (part-end (copy-marker (point) t)) + ;; We have to save the depth as we can't find the depth + ;; when narrowed. + (depth (notmuch-show-get-depth)) + (mime-type (plist-get (cadr part-args) :computed-type))) + (save-restriction + (narrow-to-region part-beg part-end) + (delete-region part-beg part-end) + (when (and mime-type (string-match "^image/" mime-type)) + (button-put button :notmuch-redisplay-data part-args)) + (apply #'notmuch-show-insert-bodypart-internal part-args) + (indent-rigidly part-beg + part-end + (* notmuch-show-indent-messages-width depth))) + (goto-char part-end) + (delete-char 1) + (notmuch-show-record-part-information (cadr part-args) + (button-start button) + part-end) + ;; Create the overlay. If the lazy-part turned out to be empty/not + ;; showable this returns nil. + (notmuch-show-create-part-overlays button part-beg part-end)))) + +(defun notmuch-show-mime-type (part) + "Return the correct mime-type to use for PART." + (when-let ((content-type (plist-get part :content-type))) + (setq content-type (downcase content-type)) + (or (and (string= content-type "application/octet-stream") + (notmuch-show-get-mime-type-of-application/octet-stream part)) + (and (string= content-type "inline patch") + "text/x-diff") + content-type))) + +;; The following variable can be overridden by let bindings. +(defvar notmuch-show-insert-header-p-function 'notmuch-show-insert-header-p + "Specify which function decides which part headers get inserted. + +The function should take two parameters, PART and HIDE, and +should return non-NIL if a header button should be inserted for +this part.") + +(defun notmuch-show-insert-header-p (part _hide) + ;; Show all part buttons except for the first part if it is text/plain. + (let ((mime-type (notmuch-show-mime-type part))) + (not (and (string= mime-type "text/plain") + (<= (plist-get part :id) 1))))) + +(defun notmuch-show-reply-insert-header-p-never (_part _hide) + nil) + +(defun notmuch-show-reply-insert-header-p-trimmed (part hide) + (let ((mime-type (notmuch-show-mime-type part))) + (and (not (notmuch-match-content-type mime-type "multipart/*")) + (not hide)))) + +(defun notmuch-show-reply-insert-header-p-minimal (part hide) + (let ((mime-type (notmuch-show-mime-type part))) + (and (notmuch-match-content-type mime-type "text/*") + (not hide)))) + +(defun notmuch-show-insert-bodypart (msg part depth &optional hide) + "Insert the body part PART at depth DEPTH in the current thread. + +HIDE determines whether to show or hide the part and the button +as follows: If HIDE is nil, show the part and the button. If HIDE +is t, hide the part initially and show the button." + (let* ((content-type (plist-get part :content-type)) + (mime-type (notmuch-show-mime-type part)) + (nth (plist-get part :id)) + (height (plist-get msg :height)) + (long (and (notmuch-match-content-type mime-type "text/*") + (> notmuch-show-max-text-part-size 0) + (> (length (plist-get part :content)) + notmuch-show-max-text-part-size))) + (deep (and notmuch-show-depth-limit + (> depth notmuch-show-depth-limit))) + (high (and notmuch-show-height-limit + (> height notmuch-show-height-limit))) + (beg (point)) + ;; This default header-p function omits the part button for + ;; the first (or only) part if this is text/plain. + (button (and (or deep long high + (funcall notmuch-show-insert-header-p-function part hide)) + (notmuch-show-insert-part-header + nth mime-type + (and content-type (downcase content-type)) + (plist-get part :filename)))) + ;; Hide the part initially if HIDE is t, or if it is too long/deep + ;; and we have a button to allow toggling. + (show-part (not (or (equal hide t) + (and deep button) + (and high button) + (and long button)))) + (content-beg (point)) + (part-data (list msg part mime-type nth depth button))) + ;; Store the computed mime-type for later use (e.g. by attachment handlers). + (plist-put part :computed-type mime-type) + (cond + (show-part + (apply #'notmuch-show-insert-bodypart-internal part-data) + (when (and button (string-match "^image/" mime-type)) + (button-put button :notmuch-redisplay-data part-data))) + (t + (when button + (button-put button :notmuch-lazy-part part-data)))) + ;; Some of the body part handlers leave point somewhere up in the + ;; part, so we make sure that we're down at the end. + (goto-char (point-max)) + ;; Ensure that the part ends with a carriage return. + (unless (bolp) + (insert "\n")) + ;; We do not create the overlay for hidden (lazy) parts until + ;; they are inserted. + (if show-part + (notmuch-show-create-part-overlays button content-beg (point)) + (save-excursion + (notmuch-show-toggle-part-invisibility button))) + (notmuch-show-record-part-information part beg (point)))) + +(defun notmuch-show-insert-body (msg body depth) + "Insert the body BODY at depth DEPTH in the current thread." + ;; Register all content IDs for this message. According to RFC + ;; 2392, content IDs are *global*, but it's okay if an MUA treats + ;; them as only global within a message. + (notmuch-show--register-cids msg (car body)) + (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body)) + +(defun notmuch-show-make-symbol (type) + (make-symbol (concat "notmuch-show-" type))) + +(defun notmuch-show-strip-re (string) + (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string)) + +(defvar notmuch-show-previous-subject "") +(make-variable-buffer-local 'notmuch-show-previous-subject) + +(defun notmuch-show-choose-duplicate (duplicate) + "Display message file with index DUPLICATE in place of the current one. + +Message file indices are based on the order the files are +discovered by `notmuch new' (and hence are somewhat arbitrary), +and correspond to those passed to the \"\\-\\-duplicate\" arguments +to the CLI. + +When called interactively, the function will prompt for the index +of the file to display. An error will be signaled if the index +is out of range." + (interactive "Nduplicate: ") + (let ((count (length (notmuch-show-get-prop :filename)))) + (when (or (> duplicate count) + (< duplicate 1)) + (error "Duplicate %d out of range [1,%d]" duplicate count))) + (notmuch-show-move-to-message-top) + (save-excursion + (let* ((extent (notmuch-show-message-extent)) + (id (notmuch-show-get-message-id)) + (depth (notmuch-show-get-depth)) + (inhibit-read-only t) + (new-msg (notmuch--run-show (list id) duplicate))) + ;; clean up existing overlays to avoid extending them. + (dolist (o (overlays-in (car extent) (cdr extent))) + (delete-overlay o)) + ;; pretend insertion is happening at end of buffer + (narrow-to-region (point-min) (car extent)) + ;; Insert first, then delete, to avoid marker for start of next + ;; message being in same place as the start of this one. + (notmuch-show-insert-msg new-msg depth) + (widen) + (delete-region (point) (cdr extent))))) + +(defun notmuch-show-insert-msg (msg depth) + "Insert the message MSG at depth DEPTH in the current thread." + (let* ((headers (plist-get msg :headers)) + ;; Indentation causes the buffer offset of the start/end + ;; points to move, so we must use markers. + message-start message-end + content-start content-end + headers-start headers-end + (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))) + (setq message-start (point-marker)) + (notmuch-show-insert-headerline msg depth (plist-get msg :tags)) + (setq content-start (point-marker)) + ;; Set `headers-start' to point after the 'Subject:' header to be + ;; compatible with the existing implementation. This just sets it + ;; to after the first header. + (notmuch-show-insert-headers headers) + (save-excursion + (goto-char content-start) + ;; If the subject of this message is the same as that of the + ;; previous message, don't display it when this message is + ;; collapsed. + (unless (string= notmuch-show-previous-subject bare-subject) + (forward-line 1)) + (setq headers-start (point-marker))) + (setq headers-end (point-marker)) + (setq notmuch-show-previous-subject bare-subject) + ;; A blank line between the headers and the body. + (insert "\n") + (notmuch-show-insert-body msg (plist-get msg :body) + (if notmuch-show-indent-content depth 0)) + ;; Ensure that the body ends with a newline. + (unless (bolp) + (insert "\n")) + (setq content-end (point-marker)) + ;; Indent according to the depth in the thread. + (when notmuch-show-indent-content + (indent-rigidly content-start + content-end + (* notmuch-show-indent-messages-width depth))) + (setq message-end (point-max-marker)) + ;; Save the extents of this message over the whole text of the + ;; message. + (put-text-property message-start message-end + :notmuch-message-extent + (cons message-start message-end)) + ;; Create overlays used to control visibility + (plist-put msg :headers-overlay (make-overlay headers-start headers-end)) + (plist-put msg :message-overlay (make-overlay headers-start content-end)) + (plist-put msg :depth depth) + ;; Save the properties for this message. Currently this saves the + ;; entire message (augmented it with other stuff), which seems + ;; like overkill. We might save a reduced subset (for example, not + ;; the content). + (notmuch-show-set-message-properties msg) + ;; Set header visibility. + (notmuch-show-headers-visible msg notmuch-message-headers-visible) + ;; Message visibility depends on whether it matched the search + ;; criteria. + (notmuch-show-message-visible msg (and (plist-get msg :match) + (not (plist-get msg :excluded)))))) + +;;; Toggle commands + +(defun notmuch-show-toggle-process-crypto () + "Toggle the processing of cryptographic MIME parts." + (interactive) + (setq notmuch-show-process-crypto (not notmuch-show-process-crypto)) + (message (if notmuch-show-process-crypto + "Processing cryptographic MIME parts." + "Not processing cryptographic MIME parts.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-elide-non-matching () + "Toggle the display of non-matching messages." + (interactive) + (setq notmuch-show-elide-non-matching-messages + (not notmuch-show-elide-non-matching-messages)) + (message (if notmuch-show-elide-non-matching-messages + "Showing matching messages only." + "Showing all messages.")) + (notmuch-show-refresh-view)) + +(defun notmuch-show-toggle-thread-indentation () + "Toggle the indentation of threads." + (interactive) + (setq notmuch-show-indent-content (not notmuch-show-indent-content)) + (message (if notmuch-show-indent-content + "Content is indented." + "Content is not indented.")) + (notmuch-show-refresh-view)) + +;;; Main insert functions + +(defun notmuch-show-insert-tree (tree depth) + "Insert the message tree TREE at depth DEPTH in the current thread." + (let ((msg (car tree)) + (replies (cadr tree))) + ;; We test whether there is a message or just some replies. + (when msg + (notmuch-show--mark-height tree) + (notmuch-show-insert-msg msg depth)) + (notmuch-show-insert-thread replies (1+ depth)))) + +(defun notmuch-show-insert-thread (thread depth) + "Insert the thread THREAD at depth DEPTH in the current forest." + (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread)) + +(defun notmuch-show-insert-forest (forest) + "Insert the forest of threads FOREST." + (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) + +;;; Link buttons + +(defvar notmuch-id-regexp + (concat + ;; Match the id: prefix only if it begins a word (to disallow, for + ;; example, matching cid:). + "\\\"-parts and mid: links into +buttons for a corresponding notmuch search." + (goto-address-fontify-region start end) + (save-excursion + (let (links + (beg-line (progn (goto-char start) (line-beginning-position))) + (end-line (progn (goto-char end) (line-end-position)))) + (goto-char beg-line) + (while (re-search-forward notmuch-id-regexp end-line t) + (push (list (match-beginning 0) (match-end 0) + (match-string-no-properties 0)) links)) + (goto-char beg-line) + (while (re-search-forward notmuch-mid-regexp end-line t) + (let* ((mid-cid (match-string-no-properties 1)) + (mid (save-match-data + (string-match "^[^/]*" mid-cid) + (url-unhex-string (match-string 0 mid-cid))))) + (push (list (match-beginning 0) (match-end 0) + (notmuch-id-to-query mid)) links))) + (pcase-dolist (`(,beg ,end ,link) links) + ;; Remove the overlay created by goto-address-mode + (remove-overlays beg end 'goto-address t) + (make-text-button beg end + :type 'notmuch-button-type + 'action `(lambda (arg) + (notmuch-show ,link current-prefix-arg)) + 'follow-link t + 'help-echo "Mouse-1, RET: search for this message" + 'face goto-address-mail-face))))) + +;;; Show command + +;;;###autoload +(defun notmuch-show (thread-id &optional elide-toggle parent-buffer query-context buffer-name) + "Run \"notmuch show\" with the given thread ID and display results. + +ELIDE-TOGGLE, if non-nil, inverts the default elide behavior. + +The optional PARENT-BUFFER is the notmuch-search buffer from +which this notmuch-show command was executed, (so that the +next thread from that buffer can be show when done with this +one). + +The optional QUERY-CONTEXT is a notmuch search term. Only +messages from the thread matching this search term are shown if +non-nil. + +The optional BUFFER-NAME provides the name of the buffer in +which the message thread is shown. If it is nil (which occurs +when the command is called interactively) the argument to the +function is used. + +Returns the buffer containing the messages, or NIL if no messages +matched." + (interactive "sNotmuch show: \nP") + (let ((buffer-name (generate-new-buffer-name + (or buffer-name + (concat "*notmuch-" thread-id "*")))) + (mm-inline-override-types (notmuch--inline-override-types))) + + (pop-to-buffer-same-window (get-buffer-create buffer-name)) + ;; No need to track undo information for this buffer. + (setq buffer-undo-list t) + (notmuch-show-mode) + ;; Set various buffer local variables to their appropriate initial + ;; state. Do this after enabling `notmuch-show-mode' so that they + ;; aren't wiped out. + (setq notmuch-show-thread-id thread-id) + (setq notmuch-show-parent-buffer parent-buffer) + (setq notmuch-show-query-context + (if (or (string= query-context "") + (string= query-context "*")) + nil + query-context)) + (setq notmuch-show-process-crypto notmuch-crypto-process-mime) + ;; If `elide-toggle', invert the default value. + (setq notmuch-show-elide-non-matching-messages + (if elide-toggle + (not notmuch-show-only-matching-messages) + notmuch-show-only-matching-messages)) + (add-hook 'post-command-hook #'notmuch-show-command-hook nil t) + (jit-lock-register #'notmuch-show-buttonise-links) + (notmuch-tag-clear-cache) + (let ((inhibit-read-only t)) + (if (notmuch-show--build-buffer) + ;; Messages were inserted into the buffer. + (current-buffer) + ;; No messages were inserted - presumably none matched the + ;; query. + (kill-buffer (current-buffer)) + (ding) + (message "No messages matched the query!") + nil)))) + +(defun notmuch-show--build-queries (thread context) + "Return a list of queries to try for this search. + +THREAD and CONTEXT are both strings, though CONTEXT may be nil. +When CONTEXT is not nil, the first query is the conjunction of it +and THREAD. The next query is THREAD alone, and serves as a +fallback if the prior matches no messages." + (let (queries) + (push (list thread) queries) + (when context + (push (list thread "and (" context ")") queries)) + queries)) + +(defun notmuch-show--header-line-format () + "Compute the header line format of a notmuch-show buffer." + (when notmuch-show-header-line + (let* ((s (notmuch-sanitize + (notmuch-show-strip-re (notmuch-show-get-subject)))) + (subject (replace-regexp-in-string "%" "%%" s))) + (cond ((stringp notmuch-show-header-line) + (format-spec notmuch-show-header-line `((?s . ,subject)))) + ((functionp notmuch-show-header-line) + (funcall notmuch-show-header-line subject)) + (notmuch-show-header-line subject))))) + +(defun notmuch-show--build-buffer (&optional state) + "Display messages matching the current buffer context. + +Apply the previously saved STATE if supplied, otherwise show the +first relevant message. + +If no messages match the query return NIL." + (let* ((cli-args (list "--exclude=false")) + (cli-args (if notmuch-show-elide-non-matching-messages (cons "--entire-thread=false" cli-args) cli-args)) + ;; "part 0 is the whole message (headers and body)" notmuch-show(1) + (cli-args (if notmuch-show-single-message (cons "--part=0" cli-args) cli-args)) + (queries (notmuch-show--build-queries + notmuch-show-thread-id notmuch-show-query-context)) + (forest nil) + ;; Must be reset every time we are going to start inserting + ;; messages into the buffer. + (notmuch-show-previous-subject "")) + ;; Use results from the first query that returns some. + (while (and (not forest) queries) + (setq forest (notmuch--run-show + (append cli-args (list "'") (car queries) (list "'")))) + (when (and forest notmuch-show-single-message) + (setq forest (list (list (list forest))))) + (setq queries (cdr queries))) + (when forest + (notmuch-show-insert-forest forest) + ;; Store the original tags for each message so that we can + ;; display changes. + (notmuch-show-mapc + (lambda () (notmuch-show-set-prop :orig-tags (notmuch-show-get-tags)))) + (setq header-line-format (notmuch-show--header-line-format)) + (run-hooks 'notmuch-show-hook) + (if state + (notmuch-show-apply-state state) + ;; With no state to apply, just go to the first message. + (notmuch-show-goto-first-wanted-message))) + ;; Report back to the caller whether any messages matched. + forest)) + +;;; Refresh command + +(defun notmuch-show-capture-state () + "Capture the state of the current buffer. + +This includes: + - the list of open messages, + - the combination of current message id with/for each visible window." + (let* ((win-list (get-buffer-window-list (current-buffer) nil t)) + (win-id-combo (mapcar (lambda (win) + (with-selected-window win + (list win (notmuch-show-get-message-id)))) + win-list))) + (list win-id-combo (notmuch-show-get-message-ids-for-open-messages)))) + +(defun notmuch-show-get-query () + "Return the current query in this show buffer." + (if notmuch-show-query-context + (concat notmuch-show-thread-id + " and (" + notmuch-show-query-context + ")") + notmuch-show-thread-id)) + +(defun notmuch-show-goto-message (msg-id) + "Go to message with msg-id." + (goto-char (point-min)) + (unless (cl-loop if (string= msg-id (notmuch-show-get-message-id)) + return t + until (not (notmuch-show-goto-message-next))) + (goto-char (point-min)) + (message "Message-id not found.")) + (notmuch-show-message-adjust)) + +(defun notmuch-show-apply-state (state) + "Apply STATE to the current buffer. + +This includes: + - opening the messages previously opened, + - closing all other messages, + - moving to the correct current message in every displayed window." + (let ((win-msg-alist (car state)) + (open (cadr state))) + ;; Open those that were open. + (goto-char (point-min)) + (cl-loop do (notmuch-show-message-visible + (notmuch-show-get-message-properties) + (member (notmuch-show-get-message-id) open)) + until (not (notmuch-show-goto-message-next))) + (dolist (win-msg-pair win-msg-alist) + (with-selected-window (car win-msg-pair) + ;; Go to the previously open message in this window + (notmuch-show-goto-message (cadr win-msg-pair)))))) + +(defun notmuch-show-refresh-view (&optional reset-state) + "Refresh the current view. + +Refreshes the current view, observing changes in display +preferences. If invoked with a prefix argument (or RESET-STATE is +non-nil) then the state of the buffer (open/closed messages) is +reset based on the original query." + (interactive "P") + (let ((inhibit-read-only t) + (mm-inline-override-types (notmuch--inline-override-types)) + (state (unless reset-state + (notmuch-show-capture-state)))) + ;; `erase-buffer' does not seem to remove overlays, which can lead + ;; to weird effects such as remaining images, so remove them + ;; manually. + (remove-overlays) + (erase-buffer) + (unless (notmuch-show--build-buffer state) + ;; No messages were inserted. + (kill-buffer (current-buffer)) + (ding) + (message "Refreshing the buffer resulted in no messages!")))) + +;;; Keymaps + +(defvar notmuch-show-stash-map + (let ((map (make-sparse-keymap))) + (define-key map "c" 'notmuch-show-stash-cc) + (define-key map "d" 'notmuch-show-stash-date) + (define-key map "F" 'notmuch-show-stash-filename) + (define-key map "f" 'notmuch-show-stash-from) + (define-key map "i" 'notmuch-show-stash-message-id) + (define-key map "I" 'notmuch-show-stash-message-id-stripped) + (define-key map "s" 'notmuch-show-stash-subject) + (define-key map "T" 'notmuch-show-stash-tags) + (define-key map "t" 'notmuch-show-stash-to) + (define-key map "l" 'notmuch-show-stash-mlarchive-link) + (define-key map "L" 'notmuch-show-stash-mlarchive-link-and-go) + (define-key map "G" 'notmuch-show-stash-git-send-email) + (define-key map "?" 'notmuch-subkeymap-help) + map) + "Submap for stash commands.") +(fset 'notmuch-show-stash-map notmuch-show-stash-map) + +(defvar notmuch-show-part-map + (let ((map (make-sparse-keymap))) + (define-key map "s" 'notmuch-show-save-part) + (define-key map "v" 'notmuch-show-view-part) + (define-key map "o" 'notmuch-show-interactively-view-part) + (define-key map "|" 'notmuch-show-pipe-part) + (define-key map "m" 'notmuch-show-choose-mime-of-part) + (define-key map "?" 'notmuch-subkeymap-help) + map) + "Submap for part commands.") +(fset 'notmuch-show-part-map notmuch-show-part-map) + +(defvar notmuch-show-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map notmuch-common-keymap) + (define-key map "Z" 'notmuch-tree-from-show-current-query) + (define-key map "U" 'notmuch-unthreaded-from-show-current-query) + (define-key map (kbd "") 'widget-backward) + (define-key map (kbd "M-TAB") 'notmuch-show-previous-button) + (define-key map (kbd "") 'notmuch-show-previous-button) + (define-key map (kbd "TAB") 'notmuch-show-next-button) + (define-key map "f" 'notmuch-show-forward-message) + (define-key map "F" 'notmuch-show-forward-open-messages) + (define-key map "b" 'notmuch-show-resend-message) + (define-key map "l" 'notmuch-show-filter-thread) + (define-key map "r" 'notmuch-show-reply-sender) + (define-key map "R" 'notmuch-show-reply) + (define-key map "|" 'notmuch-show-pipe-message) + (define-key map "w" 'notmuch-show-save-attachments) + (define-key map "V" 'notmuch-show-view-raw-message) + (define-key map "e" 'notmuch-show-resume-message) + (define-key map "c" 'notmuch-show-stash-map) + (define-key map "h" 'notmuch-show-toggle-visibility-headers) + (define-key map "k" 'notmuch-tag-jump) + (define-key map "*" 'notmuch-show-tag-all) + (define-key map "-" 'notmuch-show-remove-tag) + (define-key map "+" 'notmuch-show-add-tag) + (define-key map "X" 'notmuch-show-archive-thread-then-exit) + (define-key map "x" 'notmuch-show-archive-message-then-next-or-exit) + (define-key map "A" 'notmuch-show-archive-thread-then-next) + (define-key map "a" 'notmuch-show-archive-message-then-next-or-next-thread) + (define-key map "N" 'notmuch-show-next-message) + (define-key map "P" 'notmuch-show-previous-message) + (define-key map "n" 'notmuch-show-next-open-message) + (define-key map "p" 'notmuch-show-previous-open-message) + (define-key map (kbd "M-n") 'notmuch-show-next-thread-show) + (define-key map (kbd "M-p") 'notmuch-show-previous-thread-show) + (define-key map (kbd "DEL") 'notmuch-show-rewind) + (define-key map " " 'notmuch-show-advance-and-archive) + (define-key map (kbd "M-RET") 'notmuch-show-open-or-close-all) + (define-key map (kbd "RET") 'notmuch-show-toggle-message) + (define-key map "#" 'notmuch-show-print-message) + (define-key map "!" 'notmuch-show-toggle-elide-non-matching) + (define-key map "$" 'notmuch-show-toggle-process-crypto) + (define-key map "%" 'notmuch-show-choose-duplicate) + (define-key map "<" 'notmuch-show-toggle-thread-indentation) + (define-key map "t" 'toggle-truncate-lines) + (define-key map "." 'notmuch-show-part-map) + (define-key map "B" 'notmuch-show-browse-urls) + map) + "Keymap for \"notmuch show\" buffers.") + +;;; Mode + +(define-derived-mode notmuch-show-mode fundamental-mode "notmuch-show" + "Major mode for viewing a thread with notmuch. + +This buffer contains the results of the \"notmuch show\" command +for displaying a single thread of email from your email archives. + +By default, various components of email messages, (citations, +signatures, already-read messages), are hidden. You can make +these parts visible by clicking with the mouse button or by +pressing RET after positioning the cursor on a hidden part, (for +which \\[notmuch-show-next-button] and \\[notmuch-show-previous-button] are helpful). + +Reading the thread sequentially is well-supported by pressing +\\[notmuch-show-advance-and-archive]. This will scroll the current message (if necessary), advance +to the next message, or advance to the next thread (if already on +the last message of a thread). + +Other commands are available to read or manipulate the thread +more selectively, (such as '\\[notmuch-show-next-message]' and '\\[notmuch-show-previous-message]' to advance to messages +without removing any tags, and '\\[notmuch-show-archive-thread]' to archive an entire thread +without scrolling through with \\[notmuch-show-advance-and-archive]). + +You can add or remove arbitrary tags from the current message with +'\\[notmuch-show-add-tag]' or '\\[notmuch-show-remove-tag]'. + +All currently available key bindings: + +\\{notmuch-show-mode-map}" + (setq notmuch-buffer-refresh-function #'notmuch-show-refresh-view) + (setq buffer-read-only t) + (setq truncate-lines t) + (when (boundp 'untrusted-content) + (setq untrusted-content t)) + (setq imenu-prev-index-position-function + #'notmuch-show-imenu-prev-index-position-function) + (setq imenu-extract-index-name-function + #'notmuch-show-imenu-extract-index-name-function)) + +;;; Tree commands + +(defun notmuch-tree-from-show-current-query () + "Call notmuch tree with the current query." + (interactive) + (notmuch-tree notmuch-show-thread-id + notmuch-show-query-context + (notmuch-show-get-message-id))) + +(defun notmuch-unthreaded-from-show-current-query () + "Call notmuch unthreaded with the current query." + (interactive) + (notmuch-unthreaded notmuch-show-thread-id + notmuch-show-query-context + (notmuch-show-get-message-id))) + +;;; Movement related functions. + +(defun notmuch-show-move-to-message-top () + (goto-char (notmuch-show-message-top))) + +(defun notmuch-show-move-to-message-bottom () + (goto-char (notmuch-show-message-bottom))) + +;; There's some strangeness here where a text property applied to a +;; region a->b is not found when point is at b. We walk backwards +;; until finding the property. +(defun notmuch-show-message-extent () + "Return a cons cell containing the start and end buffer offset +of the current message." + (let (r) + (save-excursion + (while (not (setq r (get-text-property (point) :notmuch-message-extent))) + (backward-char))) + r)) + +(defun notmuch-show-message-top () + (car (notmuch-show-message-extent))) + +(defun notmuch-show-message-bottom () + (cdr (notmuch-show-message-extent))) + +(defun notmuch-show-goto-message-next () + (let ((start (point))) + (notmuch-show-move-to-message-bottom) + (if (not (eobp)) + t + (goto-char start) + nil))) + +(defun notmuch-show-goto-message-previous () + (notmuch-show-move-to-message-top) + (if (bobp) + nil + (backward-char) + (notmuch-show-move-to-message-top) + t)) + +(defun notmuch-show-mapc (function) + "Iterate through all messages in the current thread with +`notmuch-show-goto-message-next' and call FUNCTION for side +effects." + (save-excursion + (goto-char (point-min)) + (cl-loop do (funcall function) + while (notmuch-show-goto-message-next)))) + +;;; Functions relating to the visibility of messages and their components. + +(defun notmuch-show-message-visible (props visible-p) + (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :message-visible visible-p props)) + +(defun notmuch-show-headers-visible (props visible-p) + (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :headers-visible visible-p props)) + +;;; Functions for setting and getting attributes of the current message. + +(defun notmuch-show-set-message-properties (props) + (save-excursion + (notmuch-show-move-to-message-top) + (put-text-property (point) (+ (point) 1) + :notmuch-message-properties props))) + +(defun notmuch-show-get-message-properties () + "Return the properties of the current message as a plist. + +Some useful entries are: +:headers - Property list containing the headers :Date, :Subject, :From, etc. +:body - Body of the message +:tags - Tags for this message" + (save-excursion + (notmuch-show-move-to-message-top) + (get-text-property (point) :notmuch-message-properties))) + +(defun notmuch-show-get-part-properties () + "Return the properties of the innermost part containing point. + +This is the part property list retrieved from the CLI. Signals +an error if there is no part containing point." + (or (get-text-property (point) :notmuch-part) + (error "No message part here"))) + +(defun notmuch-show-set-prop (prop val &optional props) + (let ((inhibit-read-only t) + (props (or props + (notmuch-show-get-message-properties)))) + (plist-put props prop val) + (notmuch-show-set-message-properties props))) + +(defun notmuch-show-get-prop (prop &optional props) + "Get property PROP from current message in show or tree mode. + +It gets property PROP from PROPS or, if PROPS is nil, the current +message in either tree or show. This means that several utility +functions in notmuch-show can be used directly by notmuch-tree as +they just need the correct message properties." + (plist-get (or props + (cond ((eq major-mode 'notmuch-show-mode) + (notmuch-show-get-message-properties)) + ((eq major-mode 'notmuch-tree-mode) + (notmuch-tree-get-message-properties)) + (t nil))) + prop)) + +(defun notmuch-show-get-message-id (&optional bare) + "Return an id: query for the Message-Id of the current message. + +If optional argument BARE is non-nil, return +the Message-Id without id: prefix and escaping." + (if bare + (notmuch-show-get-prop :id) + (notmuch-id-to-query (notmuch-show-get-prop :id)))) + +(defun notmuch-show-get-messages-ids () + "Return all id: queries of messages in the current thread." + (let ((message-ids)) + (notmuch-show-mapc + (lambda () (push (notmuch-show-get-message-id) message-ids))) + message-ids)) + +(defun notmuch-show-get-messages-ids-search () + "Return a search string for all message ids of messages in the +current thread." + (mapconcat 'identity (notmuch-show-get-messages-ids) " or ")) + +;; dme: Would it make sense to use a macro for many of these? + +(defun notmuch-show-get-filename () + "Return the filename of the current message." + (let ((duplicate (notmuch-show-get-duplicate))) + (nth (1- duplicate) (notmuch-show-get-prop :filename)))) + +(defun notmuch-show-get-header (header &optional props) + "Return the named header of the current message, if any." + (plist-get (notmuch-show-get-prop :headers props) header)) + +(defun notmuch-show-get-cc () + (notmuch-show-get-header :Cc)) + +(defun notmuch-show-get-date () + (notmuch-show-get-header :Date)) + +(defun notmuch-show-get-duplicate () + ;; if no duplicate property exists, assume first file + (or (notmuch-show-get-prop :duplicate) 1)) + +(defun notmuch-show-get-timestamp () + (notmuch-show-get-prop :timestamp)) + +(defun notmuch-show-get-from () + (notmuch-show-get-header :From)) + +(defun notmuch-show-get-subject () + (notmuch-show-get-header :Subject)) + +(defun notmuch-show-get-to () + (notmuch-show-get-header :To)) + +(defun notmuch-show-get-depth () + (notmuch-show-get-prop :depth)) + +(defun notmuch-show-set-tags (tags) + "Set the tags of the current message." + (notmuch-show-set-prop :tags tags) + (notmuch-show-update-tags tags)) + +(defun notmuch-show-get-tags () + "Return the tags of the current message." + (notmuch-show-get-prop :tags)) + +(defun notmuch-show-message-visible-p () + "Is the current message visible?" + (notmuch-show-get-prop :message-visible)) + +(defun notmuch-show-headers-visible-p () + "Are the headers of the current message visible?" + (notmuch-show-get-prop :headers-visible)) + +(put 'notmuch-show-mark-read 'notmuch-prefix-doc + "Mark the current message as unread.") +(defun notmuch-show-mark-read (&optional unread) + "Mark the current message as read. + +Mark the current message as read by applying the tag changes in +`notmuch-show-mark-read-tags' to it (remove the \"unread\" tag by +default). If a prefix argument is given, the message will be +marked as unread, i.e. the tag changes in +`notmuch-show-mark-read-tags' will be reversed." + (interactive "P") + (when notmuch-show-mark-read-tags + (apply 'notmuch-show-tag-message + (notmuch-tag-change-list notmuch-show-mark-read-tags unread)))) + +(defun notmuch-show-seen-current-message (_start _end) + "Mark the current message read if it is open. + +We only mark it read once: if it is changed back then that is a +user decision and we should not override it." + (when (and (notmuch-show-message-visible-p) + (not (notmuch-show-get-prop :seen))) + (notmuch-show-mark-read) + (notmuch-show-set-prop :seen t))) + +(defvar notmuch-show--seen-has-errored nil) +(make-variable-buffer-local 'notmuch-show--seen-has-errored) + +(defun notmuch-show-command-hook () + (when (eq major-mode 'notmuch-show-mode) + ;; We need to redisplay to get window-start and window-end correct. + (redisplay) + (save-excursion + (condition-case nil + (funcall notmuch-show-mark-read-function (window-start) (window-end)) + ((debug error) + (unless notmuch-show--seen-has-errored + (setq notmuch-show--seen-has-errored t) + (setq header-line-format + (concat header-line-format + (propertize + " [some mark read tag changes may have failed]" + 'face font-lock-warning-face))))))))) + +(defun notmuch-show-filter-thread (query) + "Filter or LIMIT the current thread based on a new query string. + +Reshows the current thread with matches defined by the new query-string." + (interactive (list (notmuch-read-query "Filter thread: "))) + (let ((msg-id (notmuch-show-get-message-id))) + (setq notmuch-show-query-context (if (string-empty-p query) nil query)) + (notmuch-show-refresh-view t) + (notmuch-show-goto-message msg-id))) + +;;; Functions for getting attributes of several messages in the current thread. + +(defun notmuch-show-get-message-ids-for-open-messages () + "Return a list of all id: queries for open messages in the current thread." + (save-excursion + (let (message-ids done) + (goto-char (point-min)) + (while (not done) + (when (notmuch-show-message-visible-p) + (setq message-ids + (append message-ids (list (notmuch-show-get-message-id))))) + (setq done (not (notmuch-show-goto-message-next)))) + message-ids))) + +;;; Commands typically bound to keys. + +(defun notmuch-show-advance () + "Advance through thread. + +If the current message in the thread is not yet fully visible, +scroll by a near screenful to read more of the message. + +Otherwise, (the end of the current message is already within the +current window), advance to the next open message." + (interactive) + (let* ((end-of-this-message (notmuch-show-message-bottom)) + (visible-end-of-this-message (1- end-of-this-message)) + (ret nil)) + (while (invisible-p visible-end-of-this-message) + (setq visible-end-of-this-message + (max (point-min) + (1- (previous-single-char-property-change + visible-end-of-this-message 'invisible))))) + (cond + ;; Ideally we would test `end-of-this-message' against the result + ;; of `window-end', but that doesn't account for the fact that + ;; the end of the message might be hidden. + ((and visible-end-of-this-message + (> visible-end-of-this-message (window-end))) + ;; The bottom of this message is not visible - scroll. + (scroll-up nil)) + ((not (= end-of-this-message (point-max))) + ;; This is not the last message - move to the next visible one. + (notmuch-show-next-open-message)) + ((not (= (point) (point-max))) + ;; This is the last message, but the cursor is not at the end of + ;; the buffer. Move it there. + (goto-char (point-max))) + (t + ;; This is the last message - change the return value + (setq ret t))) + ret)) + +(defun notmuch-show-advance-and-archive () + "Advance through thread and archive. + +This command is intended to be one of the simplest ways to +process a thread of email. It works exactly like +notmuch-show-advance, in that it scrolls through messages in a +show buffer, except that when it gets to the end of the buffer it +archives the entire current thread, (apply changes in +`notmuch-archive-tags'), kills the buffer, and displays the next +thread from the search from which this thread was originally +shown." + (interactive) + (when (notmuch-show-advance) + (notmuch-show-archive-thread-then-next))) + +(defun notmuch-show-rewind () + "Backup through the thread (reverse scrolling compared to \ +\\[notmuch-show-advance-and-archive]). + +Specifically, if the beginning of the previous email is fewer +than `window-height' lines from the current point, move to it +just like `notmuch-show-previous-message'. + +Otherwise, just scroll down a screenful of the current message. + +This command does not modify any message tags, (it does not undo +any effects from previous calls to +`notmuch-show-advance-and-archive'." + (interactive) + (let ((start-of-message (notmuch-show-message-top)) + (start-of-window (window-start))) + (cond + ;; Either this message is properly aligned with the start of the + ;; window or the start of this message is not visible on the + ;; screen - scroll. + ((or (= start-of-message start-of-window) + (< start-of-message start-of-window)) + (scroll-down) + ;; If a small number of lines from the previous message are + ;; visible, realign so that the top of the current message is at + ;; the top of the screen. + (when (<= (count-screen-lines (window-start) start-of-message) + next-screen-context-lines) + (goto-char (notmuch-show-message-top)) + (notmuch-show-message-adjust)) + ;; Move to the top left of the window. + (goto-char (window-start))) + (t + ;; Move to the previous message. + (notmuch-show-previous-message))))) + +(put 'notmuch-show-reply 'notmuch-prefix-doc "... and prompt for sender") +(defun notmuch-show-reply (&optional prompt-for-sender) + "Reply to the sender and all recipients of the current message." + (interactive "P") + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender t + (notmuch-show-get-prop :duplicate))) + +(put 'notmuch-show-reply-sender 'notmuch-prefix-doc "... and prompt for sender") +(defun notmuch-show-reply-sender (&optional prompt-for-sender) + "Reply to the sender of the current message." + (interactive "P") + (notmuch-mua-new-reply (notmuch-show-get-message-id) prompt-for-sender nil + (notmuch-show-get-prop :duplicate))) + +(put 'notmuch-show-forward-message 'notmuch-prefix-doc + "... and prompt for sender") +(defun notmuch-show-forward-message (&optional prompt-for-sender) + "Forward the current message." + (interactive "P") + (notmuch-mua-new-forward-messages (list (notmuch-show-get-message-id)) + prompt-for-sender)) + +(put 'notmuch-show-forward-open-messages 'notmuch-prefix-doc + "... and prompt for sender") +(defun notmuch-show-forward-open-messages (&optional prompt-for-sender) + "Forward the currently open messages." + (interactive "P") + (let ((open-messages (notmuch-show-get-message-ids-for-open-messages))) + (unless open-messages + (error "No open messages to forward.")) + (notmuch-mua-new-forward-messages open-messages prompt-for-sender))) + +(defun notmuch-show-resend-message (addresses) + "Resend the current message." + (interactive (list (notmuch-address-from-minibuffer "Resend to: "))) + (when (y-or-n-p (concat "Confirm resend to " addresses " ")) + (notmuch-show-view-raw-message) + (message-resend addresses) + (notmuch-bury-or-kill-this-buffer))) + +(defun notmuch-show-message-adjust () + (recenter 0)) + +(defun notmuch-show-next-message (&optional pop-at-end) + "Show the next message. + +If a prefix argument is given and this is the last message in the +thread, navigate to the next thread in the parent search buffer." + (interactive "P") + (if (notmuch-show-goto-message-next) + (notmuch-show-message-adjust) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max))))) + +(defun notmuch-show-previous-message () + "Show the previous message or the start of the current message." + (interactive) + (if (= (point) (notmuch-show-message-top)) + (notmuch-show-goto-message-previous) + (notmuch-show-move-to-message-top)) + (notmuch-show-message-adjust)) + +(defun notmuch-show-next-open-message (&optional pop-at-end) + "Show the next open message. + +If a prefix argument is given and this is the last open message +in the thread, navigate to the next thread in the parent search +buffer. Return t if there was a next open message in the thread +to show, nil otherwise." + (interactive "P") + (let (r) + (while (and (setq r (notmuch-show-goto-message-next)) + (not (notmuch-show-message-visible-p)))) + (if r + (notmuch-show-message-adjust) + (if pop-at-end + (notmuch-show-next-thread) + (goto-char (point-max)))) + r)) + +(defun notmuch-show-next-matching-message () + "Show the next matching message." + (interactive) + (let (r) + (while (and (setq r (notmuch-show-goto-message-next)) + (not (notmuch-show-get-prop :match)))) + (if r + (notmuch-show-message-adjust) + (goto-char (point-max))))) + +(defun notmuch-show-open-if-matched () + "Open a message if it is matched (whether or not excluded)." + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-message-visible props (plist-get props :match)))) + +(defun notmuch-show-goto-first-wanted-message () + "Move to the first open message and mark it read." + (goto-char (point-min)) + (unless (notmuch-show-message-visible-p) + (notmuch-show-next-open-message)) + (when (eobp) + ;; There are no matched non-excluded messages so open all matched + ;; (necessarily excluded) messages and go to the first. + (notmuch-show-mapc 'notmuch-show-open-if-matched) + (force-window-update) + (goto-char (point-min)) + (unless (notmuch-show-message-visible-p) + (notmuch-show-next-open-message)))) + +(defun notmuch-show-previous-open-message () + "Show the previous open message." + (interactive) + (while (and (if (= (point) (notmuch-show-message-top)) + (notmuch-show-goto-message-previous) + (notmuch-show-move-to-message-top)) + (not (notmuch-show-message-visible-p)))) + (notmuch-show-message-adjust)) + +(defun notmuch-show-view-raw-message () + "View the original source of the current message." + (interactive) + (let* ((id (notmuch-show-get-message-id)) + (duplicate (notmuch-show-get-duplicate)) + (args (if (> duplicate 1) + (list (format "--duplicate=%d" duplicate) id) + (list id))) + (buf (get-buffer-create (format "*notmuch-raw-%s-%d*" id duplicate))) + (inhibit-read-only t)) + (pop-to-buffer-same-window buf) + (erase-buffer) + (let ((coding-system-for-read 'no-conversion)) + (apply #'notmuch--call-process notmuch-command nil t nil "show" "--format=raw" args)) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (view-buffer buf 'kill-buffer-if-not-modified))) + +(defun notmuch-show-resume-message () + "Resume EDITING the current draft message." + (interactive) + (notmuch-draft-resume (notmuch-show-get-message-id))) + +(put 'notmuch-show-pipe-message 'notmuch-doc + "Pipe the contents of the current message to a command.") +(put 'notmuch-show-pipe-message 'notmuch-prefix-doc + "Pipe the thread as an mbox to a command.") +(defun notmuch-show-pipe-message (entire-thread command) + "Pipe the contents of the current message (or thread) to COMMAND. + +COMMAND will be executed with the raw contents of the current +email message as stdin. Anything printed by the command to stdout +or stderr will appear in the *notmuch-pipe* buffer. + +If ENTIRE-THREAD is non-nil (or when invoked with a prefix +argument), COMMAND will receive all open messages in the current +thread (formatted as an mbox) rather than only the current +message." + (interactive (let ((query-string (if current-prefix-arg + "Pipe all open messages to command: " + "Pipe message to command: "))) + (list current-prefix-arg (read-shell-command query-string)))) + (let (shell-command) + (if entire-thread + (setq shell-command + (concat notmuch-command " show --format=mbox --exclude=false " + (shell-quote-argument + (mapconcat 'identity + (notmuch-show-get-message-ids-for-open-messages) + " OR ")) + " | " command)) + (setq shell-command + (concat notmuch-command " show --format=raw " + (shell-quote-argument (notmuch-show-get-message-id)) + " | " command))) + (let ((cwd default-directory) + (buf (get-buffer-create (concat "*notmuch-pipe*")))) + (with-current-buffer buf + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + ;; Use the originating buffer's working directory instead of + ;; that of the pipe buffer. + (cd cwd) + (let ((exit-code (call-process-shell-command shell-command nil buf))) + (goto-char (point-max)) + (set-buffer-modified-p nil) + (unless (zerop exit-code) + (pop-to-buffer buf) + (message (format "Command '%s' exited abnormally with code %d" + shell-command exit-code))))))))) + +(defun notmuch-show-tag-message (&rest tag-changes) + "Change tags for the current message. + +TAG-CHANGES is a list of tag operations for `notmuch-tag'." + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-tag (notmuch-show-get-message-id) tag-changes) + (notmuch-show-set-tags new-tags)))) + +(defun notmuch-show-tag (tag-changes) + "Change tags for the current message. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive (list (notmuch-read-tag-changes (notmuch-show-get-tags) + "Tag message"))) + (notmuch-tag (notmuch-show-get-message-id) tag-changes) + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-show-set-tags new-tags)))) + +(defun notmuch-show-tag-all (tag-changes) + "Change tags for all messages in the current show buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive + (list (let (tags) + (notmuch-show-mapc + (lambda () (setq tags (append (notmuch-show-get-tags) tags)))) + (notmuch-read-tag-changes tags "Tag thread")))) + (notmuch-tag (notmuch-show-get-messages-ids-search) tag-changes) + (notmuch-show-mapc + (lambda () + (let* ((current-tags (notmuch-show-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes))) + (unless (equal current-tags new-tags) + (notmuch-show-set-tags new-tags)))))) + +(defun notmuch-show-add-tag (tag-changes) + "Change tags for the current message (defaulting to add). + +Same as `notmuch-show-tag' but sets initial input to '+'." + (interactive + (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "+"))) + (notmuch-show-tag tag-changes)) + +(defun notmuch-show-remove-tag (tag-changes) + "Change tags for the current message (defaulting to remove). + +Same as `notmuch-show-tag' but sets initial input to '-'." + (interactive + (list (notmuch-read-tag-changes (notmuch-show-get-tags) "Tag message" "-"))) + (notmuch-show-tag tag-changes)) + +(defun notmuch-show-toggle-visibility-headers () + "Toggle the visibility of the current message headers." + (interactive) + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-headers-visible + props + (not (plist-get props :headers-visible)))) + (force-window-update)) + +(defun notmuch-show-toggle-message () + "Toggle the visibility of the current message." + (interactive) + (let ((props (notmuch-show-get-message-properties))) + (notmuch-show-message-visible + props + (not (plist-get props :message-visible)))) + (force-window-update)) + +(put 'notmuch-show-open-or-close-all 'notmuch-doc "Show all messages.") +(put 'notmuch-show-open-or-close-all 'notmuch-prefix-doc "Hide all messages.") +(defun notmuch-show-open-or-close-all () + "Set the visibility all of the messages in the current thread. + +By default make all of the messages visible. With a prefix +argument, hide all of the messages." + (interactive) + (save-excursion + (goto-char (point-min)) + (cl-loop do (notmuch-show-message-visible + (notmuch-show-get-message-properties) + (not current-prefix-arg)) + until (not (notmuch-show-goto-message-next)))) + (force-window-update)) + +(defun notmuch-show-next-button () + "Advance point to the next button in the buffer." + (interactive) + (forward-button 1)) + +(defun notmuch-show-previous-button () + "Move point back to the previous button in the buffer." + (interactive) + (backward-button 1)) + +(defun notmuch-show-next-thread (&optional show previous) + "Move to the next item in the search results, if any. + +If SHOW is non-nil, open the next item in a show +buffer. Otherwise just highlight the next item in the search +buffer. If PREVIOUS is non-nil, move to the previous item in the +search results instead. + +Return non-nil on success." + (interactive "P") + (let ((parent-buffer notmuch-show-parent-buffer)) + (notmuch-bury-or-kill-this-buffer) + (when (buffer-live-p parent-buffer) + (switch-to-buffer parent-buffer) + (and (if previous + (notmuch-search-previous-thread) + (notmuch-search-next-thread)) + show + (notmuch-search-show-thread))))) + +(defun notmuch-show-next-thread-show () + "Show the next thread in the search results, if any." + (interactive) + (notmuch-show-next-thread t)) + +(defun notmuch-show-previous-thread-show () + "Show the previous thread in the search results, if any." + (interactive) + (notmuch-show-next-thread t t)) + +(put 'notmuch-show-archive-thread 'notmuch-prefix-doc + "Un-archive each message in thread.") +(defun notmuch-show-archive-thread (&optional unarchive) + "Archive each message in thread. + +Archive each message currently shown by applying the tag changes +in `notmuch-archive-tags' to each. If a prefix argument is given, +the messages will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed. + +Note: This command is safe from any race condition of new messages +being delivered to the same thread. It does not archive the +entire thread, but only the messages shown in the current +buffer." + (interactive "P") + (when notmuch-archive-tags + (notmuch-show-tag-all + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +(defun notmuch-show-archive-thread-then-next () + "Archive all messages in the current buffer, then show next thread from search." + (interactive) + (notmuch-show-archive-thread) + (notmuch-show-next-thread t)) + +(defun notmuch-show-archive-thread-then-exit () + "Archive all messages in the current buffer, then exit back to search results." + (interactive) + (notmuch-show-archive-thread) + (notmuch-show-next-thread)) + +(put 'notmuch-show-archive-message 'notmuch-prefix-doc + "Un-archive the current message.") +(defun notmuch-show-archive-message (&optional unarchive) + "Archive the current message. + +Archive the current message by applying the tag changes in +`notmuch-archive-tags' to it. If a prefix argument is given, the +message will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed." + (interactive "P") + (when notmuch-archive-tags + (apply 'notmuch-show-tag-message + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +(defun notmuch-show-archive-message-then-next-or-exit () + "Archive current message, then show next open message in current thread. + +If at the last open message in the current thread, then exit back +to search results." + (interactive) + (notmuch-show-archive-message) + (notmuch-show-next-open-message t)) + +(defun notmuch-show-archive-message-then-next-or-next-thread () + "Archive current message, then show next open message in current or next thread. + +If at the last open message in the current thread, then show next +thread from search." + (interactive) + (notmuch-show-archive-message) + (unless (notmuch-show-next-open-message) + (notmuch-show-next-thread t))) + +(defun notmuch-show-stash-cc () + "Copy CC field of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-cc))) + +(put 'notmuch-show-stash-date 'notmuch-prefix-doc + "Copy timestamp of current message to kill-ring.") +(defun notmuch-show-stash-date (&optional stash-timestamp) + "Copy date of current message to kill-ring. + +If invoked with a prefix argument, copy timestamp of current +message to kill-ring." + (interactive "P") + (if stash-timestamp + (notmuch-common-do-stash (format "%d" (notmuch-show-get-timestamp))) + (notmuch-common-do-stash (notmuch-show-get-date)))) + +(defun notmuch-show-stash-filename () + "Copy filename of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-filename))) + +(defun notmuch-show-stash-from () + "Copy From address of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-from))) + +(put 'notmuch-show-stash-message-id 'notmuch-prefix-doc + "Copy thread: query matching current thread to kill-ring.") +(defun notmuch-show-stash-message-id (&optional stash-thread-id) + "Copy id: query matching the current message to kill-ring. + +If invoked with a prefix argument (or STASH-THREAD-ID is +non-nil), copy thread: query matching the current thread to +kill-ring." + (interactive "P") + (if stash-thread-id + (notmuch-common-do-stash notmuch-show-thread-id) + (notmuch-common-do-stash (notmuch-show-get-message-id)))) + +(defun notmuch-show-stash-message-id-stripped () + "Copy message ID of current message (sans `id:' prefix) to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-message-id t))) + +(defun notmuch-show-stash-subject () + "Copy Subject field of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-subject))) + +(defun notmuch-show-stash-tags () + "Copy tags of current message to kill-ring as a comma separated list." + (interactive) + (notmuch-common-do-stash (mapconcat 'identity (notmuch-show-get-tags) ","))) + +(defun notmuch-show-stash-to () + "Copy To address of current message to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-show-get-to))) + +(defun notmuch-show-stash-mlarchive-link (&optional mla) + "Copy an ML Archive URI for the current message to the kill-ring. + +This presumes that the message is available at the selected +Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead +of prompting the user (see +`notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (let ((url (cdr (assoc + (or mla + (let ((completion-ignore-case t)) + (completing-read + "Mailing List Archive: " + notmuch-show-stash-mlarchive-link-alist + nil t nil nil + notmuch-show-stash-mlarchive-link-default))) + notmuch-show-stash-mlarchive-link-alist)))) + (notmuch-common-do-stash + (if (functionp url) + (funcall url (notmuch-show-get-message-id t)) + (concat url (notmuch-show-get-message-id t)))))) + +(defun notmuch-show-stash-mlarchive-link-and-go (&optional mla) + "Copy an ML Archive URI for the current message to the + kill-ring and visit it. + +This presumes that the message is available at the selected +Mailing List Archive. + +If optional argument MLA is non-nil, use the provided key instead +of prompting the user (see +`notmuch-show-stash-mlarchive-link-alist')." + (interactive) + (notmuch-show-stash-mlarchive-link mla) + (browse-url (current-kill 0 t))) + +(defun notmuch-show-stash-git-helper (addresses prefix) + "Normalize all ADDRESSES while adding PREFIX. +Escape, trim, quote and add PREFIX to each address in list +of ADDRESSES, and return the result as a single string." + (mapconcat (lambda (x) + (concat prefix "\"" + ;; escape double-quotes + (replace-regexp-in-string + "\"" "\\\\\"" + ;; trim leading and trailing spaces + (replace-regexp-in-string + "\\(^ *\\| *$\\)" "" + x)) "\"")) + addresses " ")) + +(put 'notmuch-show-stash-git-send-email 'notmuch-prefix-doc + "Copy From/To/Cc of current message to kill-ring. +Use a form suitable for pasting to git send-email command line.") + +(defun notmuch-show-stash-git-send-email (&optional no-in-reply-to) + "Copy From/To/Cc/Message-Id of current message to kill-ring. +Use a form suitable for pasting to git send-email command line. + +If invoked with a prefix argument (or NO-IN-REPLY-TO is non-nil), +omit --in-reply-to=." + (interactive "P") + (notmuch-common-do-stash + (mapconcat 'identity + (remove "" + (list + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-from)) "--to=") + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-to)) "--to=") + (notmuch-show-stash-git-helper + (message-tokenize-header (notmuch-show-get-cc)) "--cc=") + (unless no-in-reply-to + (notmuch-show-stash-git-helper + (list (notmuch-show-get-message-id t)) "--in-reply-to=")))) + " "))) + +;;; Interactive part functions and their helpers + +(defun notmuch-show-generate-part-buffer (msg part) + "Return a temporary buffer containing the specified part's content." + (let ((buf (generate-new-buffer " *notmuch-part*")) + (process-crypto notmuch-show-process-crypto)) + (with-current-buffer buf + ;; This is always used in the content of mm handles, which + ;; expect undecoded, binary part content. + (insert (notmuch-get-bodypart-binary msg part process-crypto))) + buf)) + +(defun notmuch-show-current-part-handle (&optional mime-type) + "Return an mm-handle for the part containing point. + +This creates a temporary buffer for the part's content; the +caller is responsible for killing this buffer as appropriate. If +MIME-TYPE is given then set the handle's mime-type to MIME-TYPE." + (let* ((msg (notmuch-show-get-message-properties)) + (part (notmuch-show-get-part-properties)) + (buf (notmuch-show-generate-part-buffer msg part)) + (computed-type (or mime-type (plist-get part :computed-type))) + (filename (plist-get part :filename)) + (disposition (and filename `(attachment (filename . ,filename))))) + (mm-make-handle buf (list computed-type) nil nil disposition))) + +(defun notmuch-show-apply-to-current-part-handle (fn &optional mime-type) + "Apply FN to an mm-handle for the part containing point. + +This ensures that the temporary buffer created for the mm-handle +is destroyed when FN returns. If MIME-TYPE is given then force +part to be treated as if it had that mime-type." + (let ((handle (notmuch-show-current-part-handle mime-type))) + ;; Emacs puts stdout/stderr into the calling buffer so we call + ;; it from a temp-buffer, unless notmuch-show-attachment-debug + ;; is non-nil, in which case we put it in " *notmuch-part*". + (unwind-protect + (if notmuch-show-attachment-debug + (with-current-buffer (generate-new-buffer " *notmuch-part*") + (funcall fn handle)) + (with-temp-buffer + (funcall fn handle))) + (kill-buffer (mm-handle-buffer handle))))) + +(defun notmuch-show-part-button-default (&optional button) + (interactive) + (let ((button (or button (button-at (point))))) + ;; Try to toggle the part, if that fails then call the default + ;; action. The toggle fails if the part has no emacs renderable + ;; content. + (unless (notmuch-show-toggle-part-invisibility button) + (call-interactively notmuch-show-part-button-default-action)))) + +(defun notmuch-show-save-part () + "Save the MIME part containing point to a file." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-save-part)) + +(defun notmuch-show-view-part () + "View the MIME part containing point in an external viewer." + (interactive) + ;; Set mm-inlined-types to nil to force an external viewer + (let ((mm-inlined-types nil)) + (notmuch-show-apply-to-current-part-handle #'mm-display-part))) + +(defun notmuch-show-interactively-view-part () + "View the MIME part containing point, prompting for a viewer." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-interactively-view-part)) + +(defun notmuch-show-pipe-part () + "Pipe the MIME part containing point to an external command." + (interactive) + (notmuch-show-apply-to-current-part-handle #'mm-pipe-part)) + +(defun notmuch-show--mm-display-part (handle) + "Use mm-display-part to display HANDLE in a new buffer. + +If the part is displayed in an external application then close +the new buffer." + (let ((buf (get-buffer-create (generate-new-buffer-name + (concat " *notmuch-internal-part*"))))) + (pop-to-buffer-same-window buf) + (if (eq (mm-display-part handle) 'external) + (kill-buffer buf) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (view-buffer buf 'kill-buffer-if-not-modified)))) + +(defun notmuch-show-choose-mime-of-part (mime-type) + "Choose the mime type to use for displaying part." + (interactive + (list (completing-read "Mime type to use (default text/plain): " + (mailcap-mime-types) nil nil nil nil "text/plain"))) + (notmuch-show-apply-to-current-part-handle #'notmuch-show--mm-display-part + mime-type)) + +(defun notmuch-show-imenu-prev-index-position-function () + "Move point to previous message in notmuch-show buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (if (bobp) + nil + (if (eobp) + (notmuch-show-move-to-message-top) + (notmuch-show-goto-message-previous)) + t)) + +(defun notmuch-show-imenu-extract-index-name-function () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (back-to-indentation) + (buffer-substring-no-properties (if notmuch-show-imenu-indent + (line-beginning-position) + (point)) + (line-end-position))) + +(defmacro notmuch-show--with-currently-shown-message (&rest body) + "Evaluate BODY with display restricted to the currently shown +message." + `(save-excursion + (save-restriction + (let ((extent (notmuch-show-message-extent))) + (narrow-to-region (car extent) (cdr extent)) + ,@body)))) + +(defun notmuch-show--gather-urls () + "Gather any URLs in the current message." + (notmuch-show--with-currently-shown-message + (let (urls) + (goto-char (point-min)) + (while (re-search-forward goto-address-url-regexp (point-max) t) + (push (match-string-no-properties 0) urls)) + (reverse urls)))) + +(defun notmuch-show-browse-urls (&optional kill) + "Offer to browse any URLs in the current message. +With a prefix argument, copy the URL to the kill ring rather than +browsing." + (interactive "P") + (let ((urls (notmuch-show--gather-urls)) + (prompt (if kill "Copy URL to kill ring: " "Browse URL: ")) + (fn (if kill #'kill-new #'browse-url))) + (if urls + (funcall fn (completing-read prompt urls nil nil nil nil (car urls))) + (message "No URLs found.")))) + +;;; _ + +(provide 'notmuch-show) + +;;; notmuch-show.el ends here blob - /dev/null blob + 811018288f373b1df099fa7b791b27a47e313709 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-tag.el @@ -0,0 +1,587 @@ +;;; notmuch-tag.el --- tag messages within emacs -*- lexical-binding: t -*- +;; +;; Copyright © Damien Cassou +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; Damien Cassou + +;;; Code: + +(require 'crm) + +(require 'notmuch-lib) + +(declare-function notmuch-search-tag "notmuch" + (tag-changes &optional beg end only-matched)) +(declare-function notmuch-show-tag "notmuch-show" (tag-changes)) +(declare-function notmuch-tree-tag "notmuch-tree" (tag-changes)) +(declare-function notmuch-jump "notmuch-jump" (action-map prompt)) + +;;; Keys + +(define-widget 'notmuch-tag-key-type 'list + "A single key tagging binding." + :format "%v" + :args '((list :inline t + :format "%v" + (key-sequence :tag "Key") + (radio :tag "Tag operations" + (repeat :tag "Tag list" + (string :format "%v" :tag "change")) + (variable :tag "Tag variable")) + (string :tag "Name")))) + +(defcustom notmuch-tagging-keys + `((,(kbd "a") notmuch-archive-tags "Archive") + (,(kbd "u") notmuch-show-mark-read-tags "Mark read") + (,(kbd "f") ("+flagged") "Flag") + (,(kbd "s") ("+spam" "-inbox") "Mark as spam") + (,(kbd "d") ("+deleted" "-inbox") "Delete")) + "A list of keys and corresponding tagging operations. + +For each key (or key sequence) you can specify a sequence of +tagging operations to apply, or a variable which contains a list +of tagging operations such as `notmuch-archive-tags'. The final +element is a name for this tagging operation. If the name is +omitted or empty then the list of tag changes, or the variable +name is used as the name. + +The key `notmuch-tag-jump-reverse-key' (k by default) should not +be used (either as a key, or as the start of a key sequence) as +it is already bound: it switches the menu to a menu of the +reverse tagging operations. The reverse of a tagging operation is +the same list of individual tag-ops but with `+tag' replaced by +`-tag' and vice versa. + +If setting this variable outside of customize then it should be a +list of triples (lists of three elements). Each triple should be +of the form (key-binding tagging-operations name). KEY-BINDING +can be a single character or a key sequence; TAGGING-OPERATIONS +should either be a list of individual tag operations each of the +form `+tag' or `-tag', or the variable name of a variable that is +a list of tagging operations; NAME should be a name for the +tagging operation, if omitted or empty than then name is taken +from TAGGING-OPERATIONS." + :tag "List of tagging bindings" + :type '(repeat notmuch-tag-key-type) + :group 'notmuch-tag) + +;;; Faces and Formats + +(define-widget 'notmuch-tag-format-type 'lazy + "Customize widget for notmuch-tag-format and friends." + :type '(alist :key-type (regexp :tag "Tag") + :extra-offset -3 + :value-type + (radio :format "%v" + (const :tag "Hidden" nil) + (set :tag "Modified" + (string :tag "Display as") + (list :tag "Face" :extra-offset -4 + (const :format "" :inline t + (notmuch-apply-face tag)) + (list :format "%v" + (const :format "" quote) + custom-face-edit)) + (list :format "%v" :extra-offset -4 + (const :format "" :inline t + (notmuch-tag-format-image-data tag)) + (choice :tag "Image" + (const :tag "Star" + (notmuch-tag-star-icon)) + (const :tag "Empty star" + (notmuch-tag-star-empty-icon)) + (const :tag "Tag" + (notmuch-tag-tag-icon)) + (string :tag "Custom"))) + (sexp :tag "Custom"))))) + +(defface notmuch-tag-unread + '((t :foreground "red")) + "Default face used for the unread tag. + +Used in the default value of `notmuch-tag-formats'." + :group 'notmuch-faces) + +(defface notmuch-tag-flagged + '((((class color) + (background dark)) + (:foreground "LightBlue1")) + (((class color) + (background light)) + (:foreground "blue"))) + "Face used for the flagged tag. + +Used in the default value of `notmuch-tag-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-formats + '(("unread" (propertize tag 'face 'notmuch-tag-unread)) + ("flagged" (propertize tag 'face 'notmuch-tag-flagged) + (notmuch-tag-format-image-data tag (notmuch-tag-star-icon)))) + "Custom formats for individual tags. + +This is an association list of the form ((MATCH EXPR...)...), +mapping tag name regexps to lists of formatting expressions. + +The first entry whose MATCH regexp-matches a tag is used to +format that tag. The regexp is implicitly anchored, so to match +a literal tag name, just use that tag name (if it contains +special regexp characters like \".\" or \"*\", these have to be +escaped). + +The cdr of the matching entry gives a list of Elisp expressions +that modify the tag. If the list is empty, the tag is simply +hidden. Otherwise, each expression EXPR is evaluated in order: +for the first expression, the variable `tag' is bound to the tag +name; for each later expression, the variable `tag' is bound to +the result of the previous expression. In this way, each +expression can build on the formatting performed by the previous +expression. The result of the last expression is displayed in +place of the tag. + +For example, to replace a tag with another string, simply use +that string as a formatting expression. To change the foreground +of a tag to red, use the expression + (propertize tag \\='face \\='(:foreground \"red\")) + +See also `notmuch-tag-format-image', which can help replace tags +with images." + :group 'notmuch-search + :group 'notmuch-show + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +(defface notmuch-tag-deleted + '((((class color) (supports :strike-through "red")) :strike-through "red") + (t :inverse-video t)) + "Face used to display deleted tags. + +Used in the default value of `notmuch-tag-deleted-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-deleted-formats + '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted)) + (".*" (notmuch-apply-face tag `notmuch-tag-deleted))) + "Custom formats for tags when deleted. + +For deleted tags the formats in `notmuch-tag-formats' are applied +first and then these formats are applied on top; that is `tag' +passed to the function is the tag with all these previous +formattings applied. The formatted can access the original +unformatted tag as `bare-tag'. + +By default this shows deleted tags with strike-through in red, +unless strike-through is not available (e.g., emacs is running in +a terminal) in which case it uses inverse video. To hide deleted +tags completely set this to + \\='((\".*\" nil)) + +See `notmuch-tag-formats' for full documentation." + :group 'notmuch-show + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +(defface notmuch-tag-added + '((t :underline "green")) + "Default face used for added tags. + +Used in the default value for `notmuch-tag-added-formats'." + :group 'notmuch-faces) + +(defcustom notmuch-tag-added-formats + '((".*" (notmuch-apply-face tag 'notmuch-tag-added))) + "Custom formats for tags when added. + +For added tags the formats in `notmuch-tag-formats' are applied +first and then these formats are applied on top. + +To disable special formatting of added tags, set this variable to +nil. + +See `notmuch-tag-formats' for full documentation." + :group 'notmuch-show + :group 'notmuch-faces + :type 'notmuch-tag-format-type) + +;;; Icons + +(defun notmuch-tag-format-image-data (tag data) + "Replace TAG with image DATA, if available. + +This function returns a propertized string that will display image +DATA in place of TAG.This is designed for use in +`notmuch-tag-formats'. + +DATA is the content of an SVG picture (e.g., as returned by +`notmuch-tag-star-icon')." + (propertize tag 'display + `(image :type svg + :data ,data + :ascent center + :mask heuristic))) + +(defun notmuch-tag-star-icon () + "Return SVG data representing a star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-star-empty-icon () + "Return SVG data representing an empty star icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +(defun notmuch-tag-tag-icon () + "Return SVG data representing a tag icon. +This can be used with `notmuch-tag-format-image-data'." + " + + + + +") + +;;; track history of tag operations +(defvar-local notmuch-tag-history nil + "Buffer local history of `notmuch-tag' function.") +(put 'notmuch-tag-history 'permanent-local t) + +;;; Format Handling + +(defvar notmuch-tag--format-cache (make-hash-table :test 'equal) + "Cache of tag format lookup. Internal to `notmuch-tag-format-tag'.") + +(defun notmuch-tag-clear-cache () + "Clear the internal cache of tag formats." + (clrhash notmuch-tag--format-cache)) + +(defun notmuch-tag--get-formats (tag alist) + "Find the first item whose car regexp-matches TAG." + (save-match-data + ;; Don't use assoc-default since there's no way to distinguish a + ;; missing key from a present key with a null cdr. + (cl-assoc tag alist + :test (lambda (tag key) + (and (eq (string-match key tag) 0) + (= (match-end 0) (length tag))))))) + +(defun notmuch-tag--do-format (bare-tag tag formats) + "Apply a tag-formats entry to TAG." + (cond ((null formats) ;; - Tag not in `formats', + tag) ;; the format is the tag itself. + ((null (cdr formats)) ;; - Tag was deliberately hidden, + nil) ;; no format must be returned + (t + ;; Tag was found and has formats, we must apply all the + ;; formats. TAG may be null so treat that as a special case. + (let ((return-tag (copy-sequence (or tag "")))) + (dolist (format (cdr formats)) + (setq return-tag + (eval format + `((bare-tag . ,bare-tag) + (tag . ,return-tag))))) + (if (and (null tag) (equal return-tag "")) + nil + return-tag))))) + +(defun notmuch-tag-format-tag (tags orig-tags tag) + "Format TAG according to `notmuch-tag-formats'. + +TAGS and ORIG-TAGS are lists of the current tags and the original +tags; tags which have been deleted (i.e., are in ORIG-TAGS but +are not in TAGS) are shown using formats from +`notmuch-tag-deleted-formats'; tags which have been added (i.e., +are in TAGS but are not in ORIG-TAGS) are shown using formats +from `notmuch-tag-added-formats' and tags which have not been +changed (the normal case) are shown using formats from +`notmuch-tag-formats'." + (let* ((tag-state (cond ((not (member tag tags)) 'deleted) + ((not (member tag orig-tags)) 'added))) + (formatted-tag (gethash (cons tag tag-state) + notmuch-tag--format-cache + 'missing))) + (when (eq formatted-tag 'missing) + (let ((base (notmuch-tag--get-formats tag notmuch-tag-formats)) + (over (cl-case tag-state + (deleted (notmuch-tag--get-formats + tag notmuch-tag-deleted-formats)) + (added (notmuch-tag--get-formats + tag notmuch-tag-added-formats)) + (otherwise nil)))) + (setq formatted-tag (notmuch-tag--do-format tag tag base)) + (setq formatted-tag (notmuch-tag--do-format tag formatted-tag over)) + (puthash (cons tag tag-state) formatted-tag notmuch-tag--format-cache))) + formatted-tag)) + +(defun notmuch-tag-format-tags (tags orig-tags &optional face) + "Return a string representing formatted TAGS." + (let ((face (or face 'notmuch-tag-face)) + (all-tags (sort (delete-dups (append tags orig-tags nil)) #'string<))) + (notmuch-apply-face + (mapconcat #'identity + ;; nil indicated that the tag was deliberately hidden + (delq nil (mapcar (apply-partially #'notmuch-tag-format-tag + tags orig-tags) + all-tags)) + " ") + face + t))) + +;;; Hooks + +(defcustom notmuch-before-tag-hook nil + "Hooks that are run before tags of a message are modified. + +`tag-changes' will contain the tags that are about to be added or removed as +a list of strings of the form \"+TAG\" or \"-TAG\". +`query' will be a string containing the search query that determines +the messages that are about to be tagged." + :type 'hook + :options '(notmuch-hl-line-mode) + :group 'notmuch-hooks) + +(defcustom notmuch-after-tag-hook nil + "Hooks that are run after tags of a message are modified. + +`tag-changes' will contain the tags that were added or removed as +a list of strings of the form \"+TAG\" or \"-TAG\". +`query' will be a string containing the search query that determines +the messages that were tagged." + :type 'hook + :options '(notmuch-hl-line-mode) + :group 'notmuch-hooks) + +;;; User Input + +(defvar notmuch-select-tag-history nil + "Minibuffer history of `notmuch-select-tag-with-completion' function.") + +(defvar notmuch-read-tag-changes-history nil + "Minibuffer history of `notmuch-read-tag-changes' function.") + +(defun notmuch-tag-completions (&rest search-terms) + "Return a list of tags for messages matching SEARCH-TERMS. + +Return all tags if no search terms are given." + (unless search-terms + (setq search-terms (list "*"))) + (split-string + (with-output-to-string + (with-current-buffer standard-output + (apply 'notmuch--call-process notmuch-command nil t + nil "search" "--output=tags" "--exclude=false" search-terms))) + "\n+" t)) + +(defun notmuch-select-tag-with-completion (prompt &rest search-terms) + (completing-read prompt + (apply #'notmuch-tag-completions search-terms) + nil nil nil 'notmuch-select-tag-history)) + +(defun notmuch-read-tag-changes (current-tags &optional prompt initial-input) + "Prompt for tag changes in the minibuffer. + +CURRENT-TAGS is a list of tags that are present on the message +or messages to be changed. These are offered as tag removal +completions. CURRENT-TAGS may contain duplicates. PROMPT, if +non-nil, is the query string to present in the minibuffer. It +defaults to \"Tags\". INITIAL-INPUT, if non-nil, will be the +initial input in the minibuffer." + (let* ((all-tag-list (notmuch-tag-completions)) + (add-tag-list (mapcar (apply-partially 'concat "+") all-tag-list)) + (remove-tag-list (mapcar (apply-partially 'concat "-") current-tags)) + (tag-list (append add-tag-list remove-tag-list)) + (prompt (concat (or prompt "Tags") " (+add -drop): ")) + (crm-separator " ") + ;; By default, space is bound to "complete word" function. + ;; Re-bind it to insert a space instead. Note that + ;; still does the completion. + (crm-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map crm-local-completion-map) + (define-key map " " 'self-insert-command) + map))) + (completing-read-multiple prompt tag-list + nil nil initial-input + 'notmuch-read-tag-changes-history))) + +;;; Tagging + +(defun notmuch-update-tags (tags tag-changes) + "Return a copy of TAGS with additions and removals from TAG-CHANGES. + +TAG-CHANGES must be a list of tags names, each prefixed with +either a \"+\" to indicate the tag should be added to TAGS if not +present or a \"-\" to indicate that the tag should be removed +from TAGS if present." + (let ((result-tags (copy-sequence tags))) + (dolist (tag-change tag-changes) + (let ((tag (and (not (string-empty-p tag-change)) + (substring tag-change 1)))) + (cl-case (aref tag-change 0) + (?+ (unless (member tag result-tags) + (push tag result-tags))) + (?- (setq result-tags (delete tag result-tags))) + (otherwise + (error "Changed tag must be of the form `+this_tag' or `-that_tag'"))))) + (sort result-tags 'string<))) + +(defconst notmuch-tag-argument-limit 1000 + "Use batch tagging if the tagging query is longer than this. + +This limits the length of arguments passed to the notmuch CLI to +avoid system argument length limits and performance problems. + +NOTE: this variable is no longer used.") + +(make-obsolete-variable 'notmuch-tag-argument-limit nil "notmuch 0.36") + +(defun notmuch-tag (query tag-changes &optional omit-hist) + "Add/remove tags in TAG-CHANGES to messages matching QUERY. + +QUERY should be a string containing the search-terms. +TAG-CHANGES is a list of strings of the form \"+tag\" or \"-tag\" +to add or remove tags, respectively. OMIT-HIST disables history +tracking if non-nil. + +Note: Other code should always use this function to alter tags of +messages instead of running (notmuch-call-notmuch-process \"tag\" ..) +directly, so that hooks specified in notmuch-before-tag-hook and +notmuch-after-tag-hook will be run." + ;; Perform some validation + (dolist (tag-change tag-changes) + (unless (string-match-p "^[-+]\\S-+$" tag-change) + (error "Tag must be of the form `+this_tag' or `-that_tag'"))) + (unless query + (error "Nothing to tag!")) + (when tag-changes + (notmuch-dlet ((tag-changes tag-changes) + (query query)) + (run-hooks 'notmuch-before-tag-hook)) + (with-temp-buffer + (insert (concat (mapconcat #'notmuch-hex-encode tag-changes " ") " -- " query)) + (unless (= 0 + (notmuch--call-process-region + (point-min) (point-max) notmuch-command t t nil "tag" "--batch")) + (notmuch-logged-error "notmuch tag failed" (buffer-string)))) + (unless omit-hist + (push (list :query query :tag-changes tag-changes) notmuch-tag-history))) + (notmuch-dlet ((tag-changes tag-changes) + (query query)) + (run-hooks 'notmuch-after-tag-hook))) + +(defun notmuch-tag-undo () + "Undo the previous tagging operation in the current buffer. Uses +buffer local variable `notmuch-tag-history' to determine what +that operation was." + (interactive) + (when (null notmuch-tag-history) + (error "no further notmuch undo information")) + (let* ((action (pop notmuch-tag-history)) + (query (plist-get action :query)) + (changes (notmuch-tag-change-list (plist-get action :tag-changes) t))) + (notmuch-tag query changes t)) + (notmuch-refresh-this-buffer)) + +(defun notmuch-tag-change-list (tags &optional reverse) + "Convert TAGS into a list of tag changes. + +Add a \"+\" prefix to any tag in TAGS list that doesn't already +begin with a \"+\" or a \"-\". If REVERSE is non-nil, replace all +\"+\" prefixes with \"-\" and vice versa in the result." + (mapcar (lambda (str) + (let ((s (if (string-match "^[+-]" str) str (concat "+" str)))) + (if reverse + (concat (if (= (string-to-char s) ?-) "+" "-") + (substring s 1)) + s))) + tags)) + +(defvar notmuch-tag-jump-reverse-key "k" + "The key in tag-jump to switch to the reverse tag changes.") + +(defun notmuch-tag-jump (reverse) + "Create a jump menu for tagging operations. + +Creates and displays a jump menu for the tagging operations +specified in `notmuch-tagging-keys'. If REVERSE is set then it +offers a menu of the reverses of the operations specified in +`notmuch-tagging-keys'; i.e. each `+tag' is replaced by `-tag' +and vice versa." + ;; In principle this function is simple, but it has to deal with + ;; lots of cases: different modes (search/show/tree), whether a name + ;; is specified, whether the tagging operations is a list of + ;; tag-ops, or a symbol that evaluates to such a list, and whether + ;; REVERSE is specified. + (interactive "P") + (let (action-map) + (pcase-dolist (`(,key ,tag ,name) notmuch-tagging-keys) + (let* ((tag-function (cl-case major-mode + (notmuch-search-mode #'notmuch-search-tag) + (notmuch-show-mode #'notmuch-show-tag) + (notmuch-tree-mode #'notmuch-tree-tag))) + (tag (if (symbolp tag) + (symbol-value tag) + tag)) + (tag-change (if reverse + (notmuch-tag-change-list tag t) + tag)) + (name (or (and (not (string= name "")) + name) + (and (symbolp name) + (symbol-name name)))) + (name-string (if name + (if reverse + (concat "Reverse " name) + name) + (mapconcat #'identity tag-change " ")))) + (push (list key name-string + (lambda () (funcall tag-function tag-change))) + action-map))) + (push (list notmuch-tag-jump-reverse-key + (if reverse + "Forward tag changes " + "Reverse tag changes") + (apply-partially 'notmuch-tag-jump (not reverse))) + action-map) + (setq action-map (nreverse action-map)) + (notmuch-jump action-map "Tag: "))) + +;;; _ + +(provide 'notmuch-tag) + +;;; notmuch-tag.el ends here blob - /dev/null blob + aa0d92a75c8fa89698b5ea60b626cc271c27a9a7 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-tree.el @@ -0,0 +1,1514 @@ +;;; notmuch-tree.el --- displaying notmuch forests -*- lexical-binding: t -*- +;; +;; Copyright © Carl Worth +;; Copyright © David Edmondson +;; Copyright © Mark Walters +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: David Edmondson +;; Mark Walters + +;;; Code: + +(require 'mail-parse) + +(require 'notmuch-lib) +(require 'notmuch-show) +(require 'notmuch-tag) +(require 'notmuch-parser) +(require 'notmuch-jump) + +(declare-function notmuch-search "notmuch" + (&optional query oldest-first target-thread target-line + no-display)) +(declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args)) +(declare-function notmuch-read-query "notmuch" (prompt)) +(declare-function notmuch-search-find-thread-id "notmuch" (&optional bare)) +(declare-function notmuch-search-find-subject "notmuch" ()) + +;; For `notmuch-tree-next-thread-from-search'. +(declare-function notmuch-search-next-thread "notmuch" ()) +(declare-function notmuch-search-previous-thread "notmuch" ()) +(declare-function notmuch-tree-from-search-thread "notmuch" ()) + +;; this variable distinguishes the unthreaded display from the normal tree display +(defvar-local notmuch-tree-unthreaded nil + "A buffer local copy of argument unthreaded to the function notmuch-tree.") + +;;; Options + +(defgroup notmuch-tree nil + "Showing message and thread structure." + :group 'notmuch) + +(defcustom notmuch-tree-show-out nil + "View selected messages in new window rather than split-pane." + :type 'boolean + :group 'notmuch-tree) + +(defcustom notmuch-unthreaded-show-out t + "View selected messages in new window rather than split-pane." + :type 'boolean + :group 'notmuch-tree) + +(defun notmuch-tree-show-out () + (if notmuch-tree-unthreaded + notmuch-unthreaded-show-out + notmuch-tree-show-out)) + +(defcustom notmuch-tree-thread-symbols + '((prefix . " ") + (top . "─") + (top-tee . "┬") + (vertical . "│") + (vertical-tee . "├") + (bottom . "╰") + (arrow . "►")) + "Strings used to draw trees in notmuch tree results. +Symbol keys denote where the corresponding string value is used: +`prefix' is used at the top of the tree, followed by `top' if it +has no children or `top-tee' if it does; `vertical' is a bar +connecting with a response down the list skipping the current +one, while `vertical-tee' marks the current message as a reply to +the previous one; `bottom' is used at the bottom of threads. +Finally, the `arrrow' string in the list is used as a pointer to +every message. + +Common customizations include setting `prefix' to \"-\", to see +equal-length prefixes, and `arrow' to an empty string or to a +different kind of arrow point." + :type '(alist :key-type symbol :value-type string) + :group 'notmuch-tree) + +(defconst notmuch-tree--field-names + '(choice :tag "Field" + (const :tag "Date" "date") + (const :tag "Authors" "authors") + (const :tag "Subject" "subject") + (const :tag "Tree" "tree") + (const :tag "Tags" "tags") + (function))) + +(defcustom notmuch-tree-result-format + `(("date" . "%12s ") + ("authors" . "%-20s") + ((("tree" . "%s") + ("subject" . "%s")) + . " %-54s ") + ("tags" . "(%s)")) + "Result formatting for tree view. + +List of pairs of (field . format-string). Supported field +strings are: \"date\", \"authors\", \"subject\", \"tree\", +\"tags\". It is also supported to pass a function in place of a +field-name. In this case the function is passed the thread +object (plist) and format string. + +Tree means the thread tree box graphics. The field may +also be a list in which case the formatting rules are +applied recursively and then the output of all the fields +in the list is inserted according to format-string. + +Note that the author string should not contain whitespace +\(put it in the neighbouring fields instead)." + + :type `(alist :key-type (choice ,notmuch-tree--field-names + (alist :key-type ,notmuch-tree--field-names + :value-type (string :tag "Format"))) + :value-type (string :tag "Format")) + :group 'notmuch-tree) + +(defcustom notmuch-unthreaded-result-format + `(("date" . "%12s ") + ("authors" . "%-20s") + ((("subject" . "%s")) ." %-54s ") + ("tags" . "(%s)")) + "Result formatting for unthreaded tree view. + +List of pairs of (field . format-string). Supported field +strings are: \"date\", \"authors\", \"subject\", \"tree\", +\"tags\". It is also supported to pass a function in place of a +field-name. In this case the function is passed the thread +object (plist) and format string. + +Tree means the thread tree box graphics. The field may +also be a list in which case the formatting rules are +applied recursively and then the output of all the fields +in the list is inserted according to format-string. + +Note that the author string should not contain whitespace +\(put it in the neighbouring fields instead)." + + :type `(alist :key-type (choice ,notmuch-tree--field-names + (alist :key-type ,notmuch-tree--field-names + :value-type (string :tag "Format"))) + :value-type (string :tag "Format")) + :group 'notmuch-tree) + +(defun notmuch-tree-result-format () + (if notmuch-tree-unthreaded + notmuch-unthreaded-result-format + notmuch-tree-result-format)) + +;;; Faces +;;;; Faces for messages that match the query + +(defface notmuch-tree-match-face + '((t :inherit default)) + "Default face used in tree mode face for matching messages" + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-match-date-face + nil + "Face used in tree mode for the date in messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-match-author-face + '((((class color) + (background dark)) + (:foreground "OliveDrab1")) + (((class color) + (background light)) + (:foreground "dark blue")) + (t + (:bold t))) + "Face used in tree mode for the author in messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-match-subject-face + nil + "Face used in tree mode for the subject in messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-match-tree-face + nil + "Face used in tree mode for the thread tree block graphics in +messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-match-tag-face + '((((class color) + (background dark)) + (:foreground "OliveDrab1")) + (((class color) + (background light)) + (:foreground "navy blue" :bold t)) + (t + (:bold t))) + "Face used in tree mode for tags in messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +;;;; Faces for messages that do not match the query + +(defface notmuch-tree-no-match-face + '((t (:foreground "gray"))) + "Default face used in tree mode face for non-matching messages." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-no-match-date-face + nil + "Face used in tree mode for non-matching dates." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-no-match-subject-face + nil + "Face used in tree mode for non-matching subjects." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-no-match-tree-face + nil + "Face used in tree mode for the thread tree block graphics in +messages matching the query." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-no-match-author-face + nil + "Face used in tree mode for non-matching authors." + :group 'notmuch-tree + :group 'notmuch-faces) + +(defface notmuch-tree-no-match-tag-face + nil + "Face used in tree mode face for non-matching tags." + :group 'notmuch-tree + :group 'notmuch-faces) + +;;; Variables + +(defvar-local notmuch-tree-previous-subject + "The subject of the most recent result shown during the async display.") + +(defvar-local notmuch-tree-basic-query nil + "A buffer local copy of argument query to the function notmuch-tree.") + +(defvar-local notmuch-tree-query-context nil + "A buffer local copy of argument query-context to the function notmuch-tree.") + +(defvar-local notmuch-tree-target-msg nil + "A buffer local copy of argument target to the function notmuch-tree.") + +(defvar-local notmuch-tree-open-target nil + "A buffer local copy of argument open-target to the function notmuch-tree.") + +(defvar-local notmuch-tree-parent-buffer nil) + +(defvar-local notmuch-tree-message-window nil + "The window of the message pane. + +It is set in both the tree buffer and the child show buffer. It +is used to try and close the message pane when quitting tree view +or the child show buffer.") +(put 'notmuch-tree-message-window 'permanent-local t) + +(defvar-local notmuch-tree-message-buffer nil + "The buffer name of the show buffer in the message pane. + +This is used to try and make sure we don't close the message pane +if the user has loaded a different buffer in that window.") +(put 'notmuch-tree-message-buffer 'permanent-local t) + +;;; Tree wrapper commands + +(defmacro notmuch-tree--define-do-in-message-window (name cmd) + "Define NAME as a command that calls CMD interactively in the message window. +If the message pane is closed then this command does nothing. +Avoid using this macro in new code; it will be removed." + `(defun ,name () + ,(concat "(In message window) " (documentation cmd t)) + (interactive) + (when (window-live-p notmuch-tree-message-window) + (with-selected-window notmuch-tree-message-window + (call-interactively #',cmd))))) + +(notmuch-tree--define-do-in-message-window + notmuch-tree-previous-message-button + notmuch-show-previous-button) +(notmuch-tree--define-do-in-message-window + notmuch-tree-next-message-button + notmuch-show-next-button) +(notmuch-tree--define-do-in-message-window + notmuch-tree-toggle-message-process-crypto + notmuch-show-toggle-process-crypto) + +(defun notmuch-tree--message-process-crypto () + "Return value of `notmuch-show-process-crypto' in the message window. +If that window isn't alive, then return the current value. +Avoid using this function in new code; it will be removed." + (if (window-live-p notmuch-tree-message-window) + (with-selected-window notmuch-tree-message-window + notmuch-show-process-crypto) + notmuch-show-process-crypto)) + +(defmacro notmuch-tree--define-close-message-window-and (name cmd) + "Define NAME as a variant of CMD. + +NAME determines the value of `notmuch-show-process-crypto' in the +message window, closes the window, and then call CMD interactively +with that value let-bound. If the message window does not exist, +then NAME behaves like CMD." + `(defun ,name () + ,(concat "(Close message pane and) " (documentation cmd t)) + (interactive) + (let ((notmuch-show-process-crypto + (notmuch-tree--message-process-crypto))) + (notmuch-tree-close-message-window) + (call-interactively #',cmd)))) + +(notmuch-tree--define-close-message-window-and + notmuch-tree-help + notmuch-help) +(notmuch-tree--define-close-message-window-and + notmuch-tree-new-mail + notmuch-mua-new-mail) +(notmuch-tree--define-close-message-window-and + notmuch-tree-jump-search + notmuch-jump-search) +(notmuch-tree--define-close-message-window-and + notmuch-tree-forward-message + notmuch-show-forward-message) +(notmuch-tree--define-close-message-window-and + notmuch-tree-reply-sender + notmuch-show-reply-sender) +(notmuch-tree--define-close-message-window-and + notmuch-tree-reply + notmuch-show-reply) +(notmuch-tree--define-close-message-window-and + notmuch-tree-view-raw-message + notmuch-show-view-raw-message) + +;;; Keymap + +(defvar notmuch-tree-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map notmuch-common-keymap) + ;; These bindings shadow common bindings with variants + ;; that additionally close the message window. + (define-key map [remap notmuch-bury-or-kill-this-buffer] 'notmuch-tree-quit) + (define-key map [remap notmuch-search] 'notmuch-tree-to-search) + (define-key map [remap notmuch-help] 'notmuch-tree-help) + (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail) + (define-key map [remap notmuch-jump-search] 'notmuch-tree-jump-search) + + (define-key map "o" 'notmuch-tree-toggle-order) + (define-key map "i" 'notmuch-tree-toggle-hide-excluded) + (define-key map "S" 'notmuch-search-from-tree-current-query) + (define-key map "U" 'notmuch-unthreaded-from-tree-current-query) + (define-key map "Z" 'notmuch-tree-from-unthreaded-current-query) + + ;; these use notmuch-show functions directly + (define-key map "|" 'notmuch-show-pipe-message) + (define-key map "w" 'notmuch-show-save-attachments) + (define-key map "v" 'notmuch-show-view-all-mime-parts) + (define-key map "c" 'notmuch-show-stash-map) + (define-key map "b" 'notmuch-show-resend-message) + + ;; these apply to the message pane + (define-key map (kbd "M-TAB") 'notmuch-tree-previous-message-button) + (define-key map (kbd "") 'notmuch-tree-previous-message-button) + (define-key map (kbd "TAB") 'notmuch-tree-next-message-button) + (define-key map "$" 'notmuch-tree-toggle-message-process-crypto) + + ;; bindings from show (or elsewhere) but we close the message pane first. + (define-key map "f" 'notmuch-tree-forward-message) + (define-key map "r" 'notmuch-tree-reply-sender) + (define-key map "R" 'notmuch-tree-reply) + (define-key map "V" 'notmuch-tree-view-raw-message) + (define-key map "l" 'notmuch-tree-filter) + (define-key map "t" 'notmuch-tree-filter-by-tag) + (define-key map "E" 'notmuch-tree-edit-search) + + ;; The main tree view bindings + (define-key map (kbd "RET") 'notmuch-tree-show-message) + (define-key map [mouse-1] 'notmuch-tree-show-message) + (define-key map "x" 'notmuch-tree-archive-message-then-next-or-exit) + (define-key map "X" 'notmuch-tree-archive-thread-then-exit) + (define-key map "A" 'notmuch-tree-archive-thread-then-next) + (define-key map "a" 'notmuch-tree-archive-message-then-next) + (define-key map "z" 'notmuch-tree-to-tree) + (define-key map "n" 'notmuch-tree-next-matching-message) + (define-key map "p" 'notmuch-tree-prev-matching-message) + (define-key map "N" 'notmuch-tree-next-message) + (define-key map "P" 'notmuch-tree-prev-message) + (define-key map (kbd "M-p") 'notmuch-tree-prev-thread) + (define-key map (kbd "M-n") 'notmuch-tree-next-thread) + (define-key map "k" 'notmuch-tag-jump) + (define-key map "-" 'notmuch-tree-remove-tag) + (define-key map "+" 'notmuch-tree-add-tag) + (define-key map "*" 'notmuch-tree-tag-thread) + (define-key map " " 'notmuch-tree-scroll-or-next) + (define-key map (kbd "DEL") 'notmuch-tree-scroll-message-window-back) + (define-key map "e" 'notmuch-tree-resume-message) + map) + "Keymap for \"notmuch tree\" buffers.") + +;;; Message properties + +(defun notmuch-tree-get-message-properties () + "Return the properties of the current message as a plist. + +Some useful entries are: +:headers - Property list containing the headers :Date, :Subject, :From, etc. +:tags - Tags for this message." + (save-excursion + (beginning-of-line) + (get-text-property (point) :notmuch-message-properties))) + +(defun notmuch-tree-set-message-properties (props) + (save-excursion + (beginning-of-line) + (put-text-property (point) + (+ (point) 1) + :notmuch-message-properties props))) + +(defun notmuch-tree-set-prop (prop val &optional props) + (let ((inhibit-read-only t) + (props (or props + (notmuch-tree-get-message-properties)))) + (plist-put props prop val) + (notmuch-tree-set-message-properties props))) + +(defun notmuch-tree-get-prop (prop &optional props) + (plist-get (or props (notmuch-tree-get-message-properties)) + prop)) + +(defun notmuch-tree-set-tags (tags) + "Set the tags of the current message." + (notmuch-tree-set-prop :tags tags)) + +(defun notmuch-tree-get-tags () + "Return the tags of the current message." + (notmuch-tree-get-prop :tags)) + +(defun notmuch-tree-get-message-id (&optional bare) + "Return the message id of the current message." + (let ((id (notmuch-tree-get-prop :id))) + (if id + (if bare + id + (notmuch-id-to-query id)) + nil))) + +(defun notmuch-tree-get-match () + "Return whether the current message is a match." + (notmuch-tree-get-prop :match)) + +;;; Update display + +(defun notmuch-tree-refresh-result () + "Redisplay the current message line. + +This redisplays the current line based on the messages +properties (as they are now). This is used when tags are +updated." + (let ((init-point (point)) + (end (line-end-position)) + (msg (notmuch-tree-get-message-properties)) + (inhibit-read-only t)) + (beginning-of-line) + ;; This is a little tricky: we override + ;; notmuch-tree-previous-subject to get the decision between + ;; ... and a subject right and it stops notmuch-tree-insert-msg + ;; from overwriting the buffer local copy of + ;; notmuch-tree-previous-subject if this is called while the + ;; buffer is displaying. + (let ((notmuch-tree-previous-subject + (notmuch-tree-get-prop :previous-subject))) + (delete-region (point) (1+ (line-end-position))) + (notmuch-tree-insert-msg msg)) + (let ((new-end (line-end-position))) + (goto-char (if (= init-point end) + new-end + (min init-point (- new-end 1))))))) + +(defun notmuch-tree-tag-update-display (&optional tag-changes) + "Update display for TAG-CHANGES to current message. + +Updates the message in the message pane if appropriate, but does +NOT change the database." + (let* ((current-tags (notmuch-tree-get-tags)) + (new-tags (notmuch-update-tags current-tags tag-changes)) + (tree-msg-id (notmuch-tree-get-message-id))) + (unless (equal current-tags new-tags) + (notmuch-tree-set-tags new-tags) + (notmuch-tree-refresh-result) + (when (window-live-p notmuch-tree-message-window) + (with-selected-window notmuch-tree-message-window + (when (string= tree-msg-id (notmuch-show-get-message-id)) + (notmuch-show-update-tags new-tags))))))) + +;;; Commands (and some helper functions used by them) + +(defun notmuch-tree-tag (tag-changes) + "Change tags for the current message." + (interactive + (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message"))) + (notmuch-tag (notmuch-tree-get-message-id) tag-changes) + (notmuch-tree-tag-update-display tag-changes)) + +(defun notmuch-tree-add-tag (tag-changes) + "Same as `notmuch-tree-tag' but sets initial input to '+'." + (interactive + (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+"))) + (notmuch-tree-tag tag-changes)) + +(defun notmuch-tree-remove-tag (tag-changes) + "Same as `notmuch-tree-tag' but sets initial input to '-'." + (interactive + (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-"))) + (notmuch-tree-tag tag-changes)) + +(defun notmuch-tree-resume-message () + "Resume EDITING the current draft message." + (interactive) + (notmuch-tree-close-message-window) + (let ((id (notmuch-tree-get-message-id))) + (if id + (notmuch-draft-resume id) + (message "No message to resume!")))) + +;; The next two functions close the message window before calling +;; notmuch-search or notmuch-tree but they do so after the user has +;; entered the query (in case the user was basing the query on +;; something in the message window). + +(defun notmuch-tree-to-search () + "Run \"notmuch search\" with the given `query' and display results." + (interactive) + (let ((query (notmuch-read-query "Notmuch search: "))) + (notmuch-tree-close-message-window) + (notmuch-search query))) + +(defun notmuch-tree-to-tree () + "Run a query and display results in tree view." + (interactive) + (let ((query (notmuch-read-query "Notmuch tree view search: "))) + (notmuch-tree-close-message-window) + (notmuch-tree query))) + +(defun notmuch-tree-archive-thread-then-next () + "Archive all messages in the current buffer, then show next thread from search." + (interactive) + (notmuch-tree-archive-thread) + (notmuch-tree-next-thread)) + +(defun notmuch-unthreaded-from-tree-current-query () + "Switch from tree view to unthreaded view." + (interactive) + (unless notmuch-tree-unthreaded + (notmuch-tree-refresh-view 'unthreaded))) + +(defun notmuch-tree-from-unthreaded-current-query () + "Switch from unthreaded view to tree view." + (interactive) + (when notmuch-tree-unthreaded + (notmuch-tree-refresh-view 'tree))) + +(defun notmuch-search-from-tree-current-query () + "Call notmuch search with the current query." + (interactive) + (notmuch-tree-close-message-window) + (notmuch-search (notmuch-tree-get-query) + notmuch-search-oldest-first + notmuch-search-hide-excluded)) + +(defun notmuch-tree-message-window-kill-hook () + "Close the message pane when exiting the show buffer." + (let ((buffer (current-buffer))) + (when (and (window-live-p notmuch-tree-message-window) + (eq (window-buffer notmuch-tree-message-window) buffer)) + ;; We could check whether this is the only window in its frame, + ;; but simply ignoring the error that is thrown otherwise is + ;; what we had to do for Emacs 24 and we stick to that because + ;; it is still the simplest approach. + (ignore-errors + (delete-window notmuch-tree-message-window))))) + +(defun notmuch-tree-command-hook () + (when (eq major-mode 'notmuch-tree-mode) + ;; We just run the notmuch-show-command-hook on the message pane. + (when (buffer-live-p notmuch-tree-message-buffer) + (with-current-buffer notmuch-tree-message-buffer + (notmuch-show-command-hook))))) + +(defun notmuch-tree-show-message-in () + "Show the current message (in split-pane)." + (interactive) + (let ((id (notmuch-tree-get-message-id)) + (inhibit-read-only t) + buffer) + (when id + ;; We close and reopen the window to kill off un-needed buffers + ;; this might cause flickering but seems ok. + (notmuch-tree-close-message-window) + (setq notmuch-tree-message-window + (split-window-vertically (/ (window-height) 4))) + (with-selected-window notmuch-tree-message-window + (let (;; Since we are only displaying one message do not indent. + (notmuch-show-indent-messages-width 0) + (notmuch-show-single-message t) + ;; Ensure that `pop-to-buffer-same-window' uses the + ;; window we want it to use. + (display-buffer-overriding-action + '((display-buffer-same-window) + (inhibit-same-window . nil)))) + (setq buffer (notmuch-show id)))) + ;; We need the `let' as notmuch-tree-message-window is buffer local. + (let ((window notmuch-tree-message-window)) + (with-current-buffer buffer + (setq notmuch-tree-message-window window) + (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook))) + (when notmuch-show-mark-read-tags + (notmuch-tree-tag-update-display notmuch-show-mark-read-tags)) + (setq notmuch-tree-message-buffer buffer)))) + +(defun notmuch-tree-show-message-out () + "Show the current message (in whole window)." + (interactive) + (let ((id (notmuch-tree-get-message-id)) + (inhibit-read-only t)) + (when id + ;; We close the window to kill off un-needed buffers. + (notmuch-tree-close-message-window) + ;; n-s-s-m is buffer local, so use inner let. + (let ((notmuch-show-single-message t)) + (notmuch-show id))))) + +(defun notmuch-tree-show-message (arg) + "Show the current message. + +Shows in split pane or whole window according to value of +`notmuch-tree-show-out'. A prefix argument reverses the choice." + (interactive "P") + (if (or (and (notmuch-tree-show-out) (not arg)) + (and (not (notmuch-tree-show-out)) arg)) + (notmuch-tree-show-message-out) + (notmuch-tree-show-message-in))) + +(defun notmuch-tree-scroll-message-window () + "Scroll the message window (if it exists)." + (interactive) + (when (window-live-p notmuch-tree-message-window) + (with-selected-window notmuch-tree-message-window + (if (pos-visible-in-window-p (point-max)) + t + (scroll-up))))) + +(defun notmuch-tree-scroll-message-window-back () + "Scroll the message window back (if it exists)." + (interactive) + (when (window-live-p notmuch-tree-message-window) + (with-selected-window notmuch-tree-message-window + (if (pos-visible-in-window-p (point-min)) + t + (scroll-down))))) + +(defun notmuch-tree-scroll-or-next () + "Scroll the message window. +If it at end go to next message." + (interactive) + (when (notmuch-tree-scroll-message-window) + (notmuch-tree-next-matching-message))) + +(defun notmuch-tree-quit (&optional kill-both) + "Close the split view or exit tree." + (interactive "P") + (when (or (not (notmuch-tree-close-message-window)) kill-both) + (kill-buffer (current-buffer)))) + +(defun notmuch-tree-close-message-window () + "Close the message-window. Return t if close succeeds." + (interactive) + (when (and (window-live-p notmuch-tree-message-window) + (eq (window-buffer notmuch-tree-message-window) + notmuch-tree-message-buffer)) + (delete-window notmuch-tree-message-window) + (unless (get-buffer-window-list notmuch-tree-message-buffer) + (kill-buffer notmuch-tree-message-buffer)) + t)) + +(defun notmuch-tree-archive-message (&optional unarchive) + "Archive the current message. + +Archive the current message by applying the tag changes in +`notmuch-archive-tags' to it. If a prefix argument is given, the +message will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed." + (interactive "P") + (when notmuch-archive-tags + (notmuch-tree-tag + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +(defun notmuch-tree-archive-message-then-next (&optional unarchive) + "Archive the current message and move to next matching message." + (interactive "P") + (notmuch-tree-archive-message unarchive) + (notmuch-tree-next-matching-message)) + +(defun notmuch-tree-archive-thread-then-exit () + "Archive all messages in the current buffer, then exit notmuch-tree." + (interactive) + (notmuch-tree-archive-thread) + (notmuch-tree-quit t)) + +(defun notmuch-tree-archive-message-then-next-or-exit () + "Archive current message, then show next open message in current thread. + +If at the last open message in the current thread, then exit back +to search results." + (interactive) + (notmuch-tree-archive-message) + (notmuch-tree-next-matching-message t)) + +(defun notmuch-tree-next-message () + "Move to next message." + (interactive) + (forward-line) + (when (window-live-p notmuch-tree-message-window) + (notmuch-tree-show-message-in))) + +(defun notmuch-tree-prev-message () + "Move to previous message." + (interactive) + (forward-line -1) + (when (window-live-p notmuch-tree-message-window) + (notmuch-tree-show-message-in))) + +(defun notmuch-tree-goto-matching-message (&optional prev) + "Move to the next or previous matching message. + +Returns t if there was a next matching message in the thread to show, +nil otherwise." + (let ((dir (if prev -1 nil)) + (eobfn (if prev #'bobp #'eobp))) + (while (and (not (funcall eobfn)) + (not (notmuch-tree-get-match))) + (forward-line dir)) + (not (funcall eobfn)))) + +(defun notmuch-tree-matching-message (&optional prev pop-at-end) + "Move to the next or previous matching message." + (interactive "P") + (forward-line (if prev -1 nil)) + (if (and (not (notmuch-tree-goto-matching-message prev)) pop-at-end) + (notmuch-tree-quit pop-at-end) + (when (window-live-p notmuch-tree-message-window) + (notmuch-tree-show-message-in)))) + +(defun notmuch-tree-prev-matching-message (&optional pop-at-end) + "Move to previous matching message." + (interactive "P") + (notmuch-tree-matching-message t pop-at-end)) + +(defun notmuch-tree-next-matching-message (&optional pop-at-end) + "Move to next matching message." + (interactive "P") + (notmuch-tree-matching-message nil pop-at-end)) + +(defun notmuch-tree-refresh-view (&optional view) + "Refresh view." + (interactive) + (when (get-buffer-process (current-buffer)) + (error "notmuch tree process already running for current buffer")) + (let ((inhibit-read-only t) + (basic-query notmuch-tree-basic-query) + (unthreaded (cond ((eq view 'unthreaded) t) + ((eq view 'tree) nil) + (t notmuch-tree-unthreaded))) + (query-context notmuch-tree-query-context) + (target (notmuch-tree-get-message-id))) + (erase-buffer) + (notmuch-tree-worker basic-query + query-context + target + nil + unthreaded + notmuch-search-oldest-first + notmuch-search-hide-excluded))) + +(defun notmuch-tree-thread-top () + (when (notmuch-tree-get-message-properties) + (while (not (or (notmuch-tree-get-prop :first) (eobp))) + (forward-line -1)))) + +(defun notmuch-tree-prev-thread-in-tree () + "Move to the previous thread in the current tree" + (interactive) + (forward-line -1) + (notmuch-tree-thread-top) + (not (bobp))) + +(defun notmuch-tree-next-thread-in-tree () + "Get the next thread in the current tree. Returns t if a thread was +found or nil if not." + (interactive) + (forward-line 1) + (while (not (or (notmuch-tree-get-prop :first) (eobp))) + (forward-line 1)) + (not (eobp))) + +(defun notmuch-tree-next-thread-from-search (&optional previous) + "Move to the next thread in the parent search results, if any. + +If PREVIOUS is non-nil, move to the previous item in the +search results instead." + (interactive "P") + (let ((parent-buffer notmuch-tree-parent-buffer)) + (notmuch-tree-quit t) + (when (buffer-live-p parent-buffer) + (switch-to-buffer parent-buffer) + (if previous + (notmuch-search-previous-thread) + (notmuch-search-next-thread)) + (notmuch-tree-from-search-thread)))) + +(defun notmuch-tree-next-thread (&optional previous) + "Move to the next thread in the current tree or parent search results. + +If PREVIOUS is non-nil, move to the previous thread in the tree or +search results instead." + (interactive) + (unless (if previous (notmuch-tree-prev-thread-in-tree) + (notmuch-tree-next-thread-in-tree)) + (notmuch-tree-next-thread-from-search previous))) + +(defun notmuch-tree-prev-thread () + "Move to the previous thread in the current tree or parent search results." + (interactive) + (notmuch-tree-next-thread t)) + +(defun notmuch-tree-thread-mapcar (function) + "Call FUNCTION for each message in the current thread. +FUNCTION is called for side effects only." + (save-excursion + (notmuch-tree-thread-top) + (cl-loop collect (funcall function) + do (forward-line) + while (and (notmuch-tree-get-message-properties) + (not (notmuch-tree-get-prop :first)))))) + +(defun notmuch-tree-get-messages-ids-thread-search () + "Return a search string for all message ids of messages in the current thread." + (mapconcat 'identity + (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id) + " or ")) + +(defun notmuch-tree-tag-thread (tag-changes) + "Tag all messages in the current thread." + (interactive + (let ((tags (apply #'append (notmuch-tree-thread-mapcar + (lambda () (notmuch-tree-get-tags)))))) + (list (notmuch-read-tag-changes tags "Tag thread")))) + (when (notmuch-tree-get-message-properties) + (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes) + (notmuch-tree-thread-mapcar + (lambda () (notmuch-tree-tag-update-display tag-changes))))) + +(defun notmuch-tree-archive-thread (&optional unarchive) + "Archive each message in thread. + +Archive each message currently shown by applying the tag changes +in `notmuch-archive-tags' to each. If a prefix argument is given, +the messages will be \"unarchived\", i.e. the tag changes in +`notmuch-archive-tags' will be reversed. + +Note: This command is safe from any race condition of new messages +being delivered to the same thread. It does not archive the +entire thread, but only the messages shown in the current +buffer." + (interactive "P") + (when notmuch-archive-tags + (notmuch-tree-tag-thread + (notmuch-tag-change-list notmuch-archive-tags unarchive)))) + +;;; Functions for displaying the tree buffer itself + +(defun notmuch-tree-clean-address (address) + "Try to clean a single email ADDRESS for display. Return +AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return +unchanged ADDRESS if parsing fails." + (let* ((clean-address (notmuch-clean-address address)) + (p-address (car clean-address)) + (p-name (cdr clean-address))) + + ;; If we have a name return that otherwise return the address. + (or p-name p-address))) + +(defun notmuch-tree-format-field (field format-string msg) + "Format a FIELD of MSG according to FORMAT-STRING and return string." + (let* ((headers (plist-get msg :headers)) + (match (plist-get msg :match))) + (cond + ((listp field) + (format format-string (notmuch-tree-format-field-list field msg))) + + ((functionp field) + (funcall field format-string msg)) + + ((string-equal field "date") + (let ((face (if match + 'notmuch-tree-match-date-face + 'notmuch-tree-no-match-date-face))) + (propertize (format format-string (plist-get msg :date_relative)) + 'face face))) + + ((string-equal field "tree") + (let ((tree-status (plist-get msg :tree-status)) + (face (if match + 'notmuch-tree-match-tree-face + 'notmuch-tree-no-match-tree-face))) + + (propertize (format format-string + (mapconcat #'identity (reverse tree-status) "")) + 'face face))) + + ((string-equal field "subject") + (let ((bare-subject + (notmuch-sanitize + (notmuch-show-strip-re (plist-get headers :Subject)))) + (previous-subject notmuch-tree-previous-subject) + (face (if match + 'notmuch-tree-match-subject-face + 'notmuch-tree-no-match-subject-face))) + + (setq notmuch-tree-previous-subject bare-subject) + (propertize (format format-string + (if (string= previous-subject bare-subject) + " ..." + bare-subject)) + 'face face))) + + ((string-equal field "authors") + (let ((author (notmuch-tree-clean-address (plist-get headers :From))) + (len (length (format format-string ""))) + (face (if match + 'notmuch-tree-match-author-face + 'notmuch-tree-no-match-author-face))) + (when (> (length author) len) + (setq author (substring author 0 len))) + (propertize (format format-string author) 'face face))) + + ((string-equal field "tags") + (let ((tags (plist-get msg :tags)) + (orig-tags (plist-get msg :orig-tags)) + (face (if match + 'notmuch-tree-match-tag-face + 'notmuch-tree-no-match-tag-face))) + (format format-string (notmuch-tag-format-tags tags orig-tags face))))))) + +(defun notmuch-tree-format-field-list (field-list msg) + "Format fields of MSG according to FIELD-LIST and return string." + (let ((face (if (plist-get msg :match) + 'notmuch-tree-match-face + 'notmuch-tree-no-match-face)) + (result-string)) + (dolist (spec field-list result-string) + (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg))) + (setq result-string (concat result-string field-string)))) + (notmuch-apply-face result-string face t))) + +(defun notmuch-tree-insert-msg (msg) + "Insert the message MSG according to notmuch-tree-result-format." + ;; We need to save the previous subject as it will get overwritten + ;; by the insert-field calls. + (let ((previous-subject notmuch-tree-previous-subject)) + (insert (notmuch-tree-format-field-list (notmuch-tree-result-format) msg)) + (notmuch-tree-set-message-properties msg) + (notmuch-tree-set-prop :previous-subject previous-subject) + (insert "\n"))) + +(defun notmuch-tree-goto-and-insert-msg (msg) + "Insert msg at the end of the buffer. Move point to msg if it is the target." + (save-excursion + (goto-char (point-max)) + (notmuch-tree-insert-msg msg)) + (let ((msg-id (notmuch-id-to-query (plist-get msg :id))) + (target notmuch-tree-target-msg)) + (when (or (and (not target) (plist-get msg :match)) + (string= msg-id target)) + (setq notmuch-tree-target-msg "found") + (goto-char (point-max)) + (forward-line -1) + (when notmuch-tree-open-target + (notmuch-tree-show-message-in) + (notmuch-tree-command-hook))))) + +(defun notmuch-tree-insert-tree (tree depth tree-status first last) + "Insert the message tree TREE at depth DEPTH in the current thread. + +A message tree is another name for a single sub-thread: i.e., a +message together with all its descendents." + (let ((msg (car tree)) + (replies (cadr tree)) + ;; outline level, computed from the message's depth and + ;; whether or not it's the first message in the tree. + (level (1+ (if (and (eq 0 depth) (not first)) 1 depth)))) + (cond + ((and (< 0 depth) (not last)) + (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status)) + ((and (< 0 depth) last) + (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) + ((and (eq 0 depth) first last) + (push (alist-get 'prefix notmuch-tree-thread-symbols) tree-status)) + ((and (eq 0 depth) first (not last)) + (push (alist-get 'top-tee notmuch-tree-thread-symbols) tree-status)) + ((and (eq 0 depth) (not first) last) + (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) + ((and (eq 0 depth) (not first) (not last)) + (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status))) + (push (concat (alist-get (if replies 'top-tee 'top) notmuch-tree-thread-symbols) + (alist-get 'arrow notmuch-tree-thread-symbols)) + tree-status) + (setq msg (plist-put msg :first (and first (eq 0 depth)))) + (setq msg (plist-put msg :tree-status tree-status)) + (setq msg (plist-put msg :orig-tags (plist-get msg :tags))) + (setq msg (plist-put msg :level level)) + (notmuch-tree-goto-and-insert-msg msg) + (pop tree-status) + (pop tree-status) + (if last + (push " " tree-status) + (push (alist-get 'vertical notmuch-tree-thread-symbols) tree-status)) + (notmuch-tree-insert-thread replies (1+ depth) tree-status))) + +(defun notmuch-tree-insert-thread (thread depth tree-status) + "Insert the collection of sibling sub-threads THREAD at depth +DEPTH in the current forest." + (let ((n (length thread))) + (cl-loop for tree in thread + for count from 1 to n + do (notmuch-tree-insert-tree tree depth tree-status + (eq count 1) + (eq count n))))) + +(defun notmuch-tree-insert-forest-thread (forest-thread) + "Insert a single complete thread." + ;; Reset at the start of each main thread. + (setq notmuch-tree-previous-subject nil) + (notmuch-tree-insert-thread forest-thread 0 nil)) + +(defun notmuch-tree-insert-forest (forest) + "Insert a forest of threads. + +This function inserts a collection of several complete threads as +passed to it by notmuch-tree-process-filter." + (mapc 'notmuch-tree-insert-forest-thread forest)) + +(define-derived-mode notmuch-tree-mode fundamental-mode "notmuch-tree" + "Major mode displaying messages (as opposed to threads) of a notmuch search. + +This buffer contains the results of a \"notmuch tree\" of your +email archives. Each line in the buffer represents a single +message giving the relative date, the author, subject, and any +tags. + +Pressing \\[notmuch-tree-show-message] on any line displays that message. + +Complete list of currently available key bindings: + +\\{notmuch-tree-mode-map}" + (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view) + (when notmuch-hl-line + (hl-line-mode 1)) + (setq buffer-read-only t) + (setq truncate-lines t) + (when (boundp 'untrusted-content) + (setq untrusted-content t)) + (when notmuch-tree-outline-enabled (notmuch-tree-outline-mode 1))) + +(defvar notmuch-tree-process-exit-functions nil + "Functions called when the process inserting a tree of results finishes. + +Functions in this list are called with one argument, the process +object, and with the tree results buffer as the current buffer.") + +(defun notmuch-tree-process-sentinel (proc _msg) + "Add a message to let user know when \"notmuch tree\" exits." + (let ((buffer (process-buffer proc)) + (status (process-status proc)) + (exit-status (process-exit-status proc))) + (when (memq status '(exit signal)) + (kill-buffer (process-get proc 'parse-buf)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (when (eq status 'signal) + (insert "Incomplete search results (tree view process was killed).\n")) + (when (eq status 'exit) + (insert "End of search results.") + (unless (= exit-status 0) + (insert (format " (process returned %d)" exit-status))) + (insert "\n")))) + (when (and notmuch-hl-line (= exit-status 0)) + (notmuch-hl-line-mode)) + (run-hook-with-args 'notmuch-tree-process-exit-functions proc)))))) + +(defun notmuch-tree-process-filter (proc string) + "Process and filter the output of \"notmuch show\" for tree view." + (let ((results-buf (process-buffer proc)) + (parse-buf (process-get proc 'parse-buf)) + (inhibit-read-only t)) + (if (not (buffer-live-p results-buf)) + (delete-process proc) + (with-current-buffer parse-buf + ;; Insert new data + (save-excursion + (goto-char (point-max)) + (insert string)) + (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread + results-buf)) + (with-current-buffer results-buf + (when notmuch-hl-line + (notmuch-hl-line-mode)))))) + +(defun notmuch-tree-worker (basic-query &optional query-context target + open-target unthreaded oldest-first + exclude) + "Insert the tree view of the search in the current buffer. + +This is is a helper function for notmuch-tree. The arguments are +the same as for the function notmuch-tree." + (interactive) + (notmuch-tree-mode) + (add-hook 'post-command-hook #'notmuch-tree-command-hook t t) + (setq notmuch-search-oldest-first oldest-first) + (setq notmuch-search-hide-excluded exclude) + (setq notmuch-tree-unthreaded unthreaded) + (setq notmuch-tree-basic-query basic-query) + (setq notmuch-tree-query-context (if (or (string= query-context "") + (string= query-context "*")) + nil + query-context)) + (setq notmuch-tree-target-msg target) + (setq notmuch-tree-open-target open-target) + ;; Set the default value for `notmuch-show-process-crypto' in this + ;; buffer. Although we don't use this some of the functions we call + ;; (such as reply) do. It is a buffer local variable so setting it + ;; will not affect genuine show buffers. + (setq notmuch-show-process-crypto notmuch-crypto-process-mime) + (erase-buffer) + (goto-char (point-min)) + (let* ((search-args (concat basic-query + (and query-context + (concat " and (" query-context ")")))) + (sort-arg (if oldest-first "--sort=oldest-first" "--sort=newest-first")) + (message-arg (if unthreaded "--unthreaded" "--entire-thread")) + (exclude-arg (if exclude "--exclude=true" "--exclude=false"))) + (when (equal (car (notmuch--process-lines notmuch-command "count" search-args)) "0") + (setq search-args basic-query)) + (notmuch-tag-clear-cache) + (let ((proc (notmuch-start-notmuch + "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel + "show" "--body=false" "--format=sexp" "--format-version=5" + sort-arg message-arg exclude-arg search-args)) + ;; Use a scratch buffer to accumulate partial output. + ;; This buffer will be killed by the sentinel, which + ;; should be called no matter how the process dies. + (parse-buf (generate-new-buffer " *notmuch tree parse*"))) + (process-put proc 'parse-buf parse-buf) + (set-process-filter proc 'notmuch-tree-process-filter) + (set-process-query-on-exit-flag proc nil)))) + +(defun notmuch-tree-get-query () + "Return the current query in this tree buffer." + (if notmuch-tree-query-context + (concat notmuch-tree-basic-query + " and (" + notmuch-tree-query-context + ")") + notmuch-tree-basic-query)) + +(defun notmuch-tree-toggle-order () + "Toggle the current search order. + +This command toggles the sort order for the current search. The +default sort order is defined by `notmuch-search-oldest-first'." + (interactive) + (setq notmuch-search-oldest-first (not notmuch-search-oldest-first)) + (notmuch-tree-refresh-view)) + +(defun notmuch-tree-toggle-hide-excluded () + "Toggle whether to hide excluded messages. + +This command toggles whether to hide excluded messages for the current +search. The default value for this is defined by `notmuch-search-hide-excluded'." + (interactive) + (setq notmuch-search-hide-excluded (not notmuch-search-hide-excluded)) + (notmuch-tree-refresh-view)) + +;;;###autoload +(defun notmuch-tree (&optional query query-context target buffer-name + open-target unthreaded parent-buffer + oldest-first hide-excluded) + "Display threads matching QUERY in tree view. + +The arguments are: + QUERY: the main query. This can be any query but in many cases will be + a single thread. If nil this is read interactively from the minibuffer. + QUERY-CONTEXT: is an additional term for the query. The query used + is QUERY and QUERY-CONTEXT unless that does not match any messages + in which case we fall back to just QUERY. + TARGET: A message ID (with the id: prefix) that will be made + current if it appears in the tree view results. + BUFFER-NAME: the name of the buffer to display the tree view. If + it is nil \"*notmuch-tree\" followed by QUERY is used. + OPEN-TARGET: If TRUE open the target message in the message pane. + UNTHREADED: If TRUE only show matching messages in an unthreaded view." + (interactive + (list + ;; Prompt for a query + nil + ;; Fill other args with nil. + nil nil nil nil nil nil + ;; Populate these from the default value of these options. + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) + (unless query + (setq query (notmuch-read-query (concat "Notmuch " + (if unthreaded "unthreaded " "tree ") + "view search: ")))) + (let* ((name + (or buffer-name + (notmuch-search-buffer-title query + (if unthreaded "unthreaded" "tree")))) + (buffer (get-buffer-create (generate-new-buffer-name name))) + (inhibit-read-only t)) + (pop-to-buffer-same-window buffer)) + ;; Don't track undo information for this buffer + (setq buffer-undo-list t) + (notmuch-tree-worker query query-context target open-target + unthreaded oldest-first hide-excluded) + (setq notmuch-tree-parent-buffer parent-buffer) + (setq truncate-lines t)) + +(defun notmuch-unthreaded (&optional query query-context target buffer-name + open-target oldest-first hide-excluded) + "Display threads matching QUERY in unthreaded view. + +See function NOTMUCH-TREE for documentation of the arguments" + (interactive + (list + ;; Prompt for a query + nil + ;; Fill other args with nil. + nil nil nil nil + ;; Populate these from the default value of these options. + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) + (notmuch-tree query query-context target buffer-name open-target + t nil oldest-first hide-excluded)) + +(defun notmuch-tree-filter (query) + "Filter or LIMIT the current search results based on an additional query string. + +Runs a new tree search matching only messages that match both the +current search results AND the additional query string provided." + (interactive (list (notmuch-read-query "Filter search: "))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)) + (grouped-query (notmuch-group-disjunctive-query-string query)) + (grouped-original-query (notmuch-group-disjunctive-query-string + (notmuch-tree-get-query)))) + (notmuch-tree-close-message-window) + (notmuch-tree (if (string= grouped-original-query "*") + grouped-query + (concat grouped-original-query " and " grouped-query))))) + +(defun notmuch-tree-filter-by-tag (tag) + "Filter the current search results based on a single TAG. + +Run a new search matching only messages that match the current +search results and that are also tagged with the given TAG." + (interactive + (list (notmuch-select-tag-with-completion "Filter by tag: " + notmuch-tree-basic-query))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) + (notmuch-tree-close-message-window) + (notmuch-tree (concat notmuch-tree-basic-query " and tag:" tag) + notmuch-tree-query-context + nil + nil + nil + notmuch-tree-unthreaded + nil + notmuch-search-oldest-first + notmuch-search-hide-excluded))) + +(defun notmuch-tree-edit-search (query) + "Edit the current search" + (interactive (list (read-from-minibuffer "Edit search: " + notmuch-tree-basic-query))) + (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) + (notmuch-tree-close-message-window) + (notmuch-tree query + notmuch-tree-query-context + nil + nil + nil + notmuch-tree-unthreaded + nil + notmuch-search-oldest-first))) + +;;; Tree outline mode +;;;; Custom variables +(defcustom notmuch-tree-outline-enabled nil + "Whether to automatically activate `notmuch-tree-outline-mode' in tree views." + :type 'boolean) + +(defcustom notmuch-tree-outline-visibility 'hide-others + "Default state of the forest outline for `notmuch-tree-outline-mode'. + +This variable controls the state of a forest initially and after +a movement command. If set to nil, all trees are displayed while +the symbol hide-all indicates that all trees in the forest should +be folded and hide-other that only the first one should be +unfolded." + :type '(choice (const :tag "Show all" nil) + (const :tag "Hide others" hide-others) + (const :tag "Hide all" hide-all))) + +(defcustom notmuch-tree-outline-auto-close nil + "Close message and tree windows when moving past the last message." + :type 'boolean) + +(defcustom notmuch-tree-outline-open-on-next nil + "Open new messages under point if they are closed when moving to next one. + +When this flag is set, using the command +`notmuch-tree-outline-next' with point on a header for a new +message that is not shown will open its `notmuch-show' buffer +instead of moving point to next matching message." + :type 'boolean) + +;;;; Helper functions +(defsubst notmuch-tree-outline--pop-at-end (pop-at-end) + (if notmuch-tree-outline-auto-close (not pop-at-end) pop-at-end)) + +(defun notmuch-tree-outline--set-visibility () + (when (and notmuch-tree-outline-mode (> (point-max) (point-min))) + (cl-case notmuch-tree-outline-visibility + (hide-others (notmuch-tree-outline-hide-others)) + (hide-all (outline-hide-body))))) + +(defun notmuch-tree-outline--on-exit (proc) + (when (eq (process-status proc) 'exit) + (notmuch-tree-outline--set-visibility))) + +(add-hook 'notmuch-tree-process-exit-functions #'notmuch-tree-outline--on-exit) + +(defsubst notmuch-tree-outline--level (&optional props) + (or (plist-get (or props (notmuch-tree-get-message-properties)) :level) 0)) + +(defsubst notmuch-tree-outline--message-open-p () + (and (buffer-live-p notmuch-tree-message-buffer) + (get-buffer-window notmuch-tree-message-buffer) + (let ((id (notmuch-tree-get-message-id))) + (and id + (with-current-buffer notmuch-tree-message-buffer + (string= (notmuch-show-get-message-id) id)))))) + +(defsubst notmuch-tree-outline--at-original-match-p () + (and (notmuch-tree-get-prop :match) + (equal (notmuch-tree-get-prop :orig-tags) + (notmuch-tree-get-prop :tags)))) + +(defun notmuch-tree-outline--next (prev thread pop-at-end &optional open-new) + (cond (thread + (notmuch-tree-thread-top) + (if prev + (outline-backward-same-level 1) + (outline-forward-same-level 1)) + (when (> (notmuch-tree-outline--level) 0) (outline-show-branches)) + (notmuch-tree-outline--next nil nil pop-at-end t)) + ((and (or open-new notmuch-tree-outline-open-on-next) + (notmuch-tree-outline--at-original-match-p) + (not (notmuch-tree-outline--message-open-p))) + (notmuch-tree-outline-hide-others t)) + (t (outline-next-visible-heading (if prev -1 1)) + (unless (notmuch-tree-get-prop :match) + (notmuch-tree-matching-message prev pop-at-end)) + (notmuch-tree-outline-hide-others t)))) + +;;;; User commands +(defun notmuch-tree-outline-hide-others (&optional and-show) + "Fold all threads except the one around point. +If AND-SHOW is t, make the current message visible if it's not." + (interactive) + (save-excursion + (while (and (not (bobp)) (> (notmuch-tree-outline--level) 1)) + (outline-previous-heading)) + (outline-hide-sublevels 1)) + (when (> (notmuch-tree-outline--level) 0) + (outline-show-subtree) + (when and-show (notmuch-tree-show-message nil)))) + +(defun notmuch-tree-outline-next (&optional pop-at-end) + "Next matching message in a forest, taking care of thread visibility. +A prefix argument reverses the meaning of `notmuch-tree-outline-auto-close'." + (interactive "P") + (let ((pop (notmuch-tree-outline--pop-at-end pop-at-end))) + (if (null notmuch-tree-outline-visibility) + (notmuch-tree-matching-message nil pop) + (notmuch-tree-outline--next nil nil pop)))) + +(defun notmuch-tree-outline-previous (&optional pop-at-end) + "Previous matching message in forest, taking care of thread visibility. +With prefix, quit the tree view if there is no previous message." + (interactive "P") + (if (null notmuch-tree-outline-visibility) + (notmuch-tree-prev-matching-message pop-at-end) + (notmuch-tree-outline--next t nil pop-at-end))) + +(defun notmuch-tree-outline-next-thread () + "Next matching thread in forest, taking care of thread visibility." + (interactive) + (if (null notmuch-tree-outline-visibility) + (notmuch-tree-next-thread) + (notmuch-tree-outline--next nil t nil))) + +(defun notmuch-tree-outline-previous-thread () + "Previous matching thread in forest, taking care of thread visibility." + (interactive) + (if (null notmuch-tree-outline-visibility) + (notmuch-tree-prev-thread) + (notmuch-tree-outline--next t t nil))) + +;;;; Mode definition +(defvar notmuch-tree-outline-mode-lighter nil + "The lighter mark for notmuch-tree-outline mode. +Usually empty since outline-minor-mode's lighter will be active.") + +(define-minor-mode notmuch-tree-outline-mode + "Minor mode allowing message trees to be folded as outlines. + +When this mode is set, each thread and subthread in the results +list is treated as a foldable section, with its first message as +its header. + +The mode just makes available in the tree buffer all the +keybindings in `outline-minor-mode', and binds the following +additional keys: + +\\{notmuch-tree-outline-mode-map} + +The customizable variable `notmuch-tree-outline-visibility' +controls how navigation in the buffer is affected by this mode: + + - If it is set to nil, `notmuch-tree-outline-previous', + `notmuch-tree-outline-next', and their thread counterparts + behave just as the corresponding notmuch-tree navigation keys + when this mode is not enabled. + + - If, on the other hand, `notmuch-tree-outline-visibility' is + set to a non-nil value, these commands hiding the outlines of + the trees you are not reading as you move to new messages. + +To enable notmuch-tree-outline-mode by default in all +notmuch-tree buffers, just set +`notmuch-tree-outline-mode-enabled' to t." + :lighter notmuch-tree-outline-mode-lighter + :keymap `((,(kbd "TAB") . outline-cycle) + (,(kbd "M-TAB") . outline-cycle-buffer) + ("n" . notmuch-tree-outline-next) + ("p" . notmuch-tree-outline-previous) + (,(kbd "M-n") . notmuch-tree-outline-next-thread) + (,(kbd "M-p") . notmuch-tree-outline-previous-thread)) + (outline-minor-mode notmuch-tree-outline-mode) + (unless (derived-mode-p 'notmuch-tree-mode) + (user-error "notmuch-tree-outline-mode is only meaningful for notmuch trees!")) + (if notmuch-tree-outline-mode + (progn (setq-local outline-regexp "^[^\n]+") + (setq-local outline-level #'notmuch-tree-outline--level) + (notmuch-tree-outline--set-visibility)) + (setq-local outline-regexp (default-value 'outline-regexp)) + (setq-local outline-level (default-value 'outline-level)))) + +;;; _ + +(provide 'notmuch-tree) + +;;; notmuch-tree.el ends here blob - /dev/null blob + fd8a9d1e2296db96e6cf6642bbe0ba35819942ae (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch-wash.el @@ -0,0 +1,418 @@ +;;; notmuch-wash.el --- cleaning up message bodies -*- lexical-binding: t -*- +;; +;; Copyright © Carl Worth +;; Copyright © David Edmondson +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; David Edmondson + +;;; Code: + +(require 'coolj) +(require 'diff-mode) +(require 'notmuch-lib) + +(declare-function notmuch-show-insert-bodypart "notmuch-show" + (msg part depth &optional hide)) +(defvar notmuch-show-indent-messages-width) + +;;; Options + +(defgroup notmuch-wash nil + "Cleaning up messages for display." + :group 'notmuch) + +(defcustom notmuch-wash-signature-regexp "^\\(-- ?\\|_+\\)$" + "Pattern to match a line that separates content from signature." + :type 'regexp + :group 'notmuch-wash) + +(defcustom notmuch-wash-citation-regexp "\\(^[[:space:]]*>.*\n\\)+" + "Pattern to match citation lines." + :type 'regexp + :group 'notmuch-wash) + +(defcustom notmuch-wash-original-regexp "^\\(--+\s?[oO]riginal [mM]essage\s?--+\\)$" + "Pattern to match a line that separates original message from +reply in top-posted message." + :type 'regexp + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-signature-hidden-format + "[ %d-line signature. Click/Enter to show. ]" + "String used to construct button text for hidden signatures. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-signature-visible-format + "[ %d-line signature. Click/Enter to hide. ]" + "String used to construct button text for visible signatures. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-citation-hidden-format + "[ %d more citation lines. Click/Enter to show. ]" + "String used to construct button text for hidden citations. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-citation-visible-format + "[ %d more citation lines. Click/Enter to hide. ]" + "String used to construct button text for visible citations. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-original-hidden-format + "[ %d-line hidden original message. Click/Enter to show. ]" + "String used to construct button text for hidden citations. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-button-original-visible-format + "[ %d-line original message. Click/Enter to hide. ]" + "String used to construct button text for visible citations. +Can use up to one integer format parameter, i.e. %d." + :type 'string + :group 'notmuch-wash) + +(defcustom notmuch-wash-signature-lines-max 12 + "Maximum length of signature that will be hidden by default." + :type 'integer + :group 'notmuch-wash) + +(defcustom notmuch-wash-citation-lines-prefix 3 + "Always show at least this many lines from the start of a citation. + +If there is one more line than the sum of +`notmuch-wash-citation-lines-prefix' and +`notmuch-wash-citation-lines-suffix', show that, otherwise +collapse the remaining lines into a button." + :type 'integer + :group 'notmuch-wash) + +(defcustom notmuch-wash-citation-lines-suffix 3 + "Always show at least this many lines from the end of a citation. + +If there is one more line than the sum of +`notmuch-wash-citation-lines-prefix' and +`notmuch-wash-citation-lines-suffix', show that, otherwise +collapse the remaining lines into a button." + :type 'integer + :group 'notmuch-wash) + +(defcustom notmuch-wash-wrap-lines-length nil + "Wrap line after at most this many characters. + +If this is nil, lines in messages will be wrapped to fit in the +current window. If this is a number, lines will be wrapped after +this many characters (ignoring indentation due to thread depth) +or at the window width (whichever one is lower)." + :type '(choice (const :tag "window width" nil) + (integer :tag "number of characters")) + :group 'notmuch-wash) + +;;; Faces + +(defface notmuch-wash-toggle-button + '((t (:inherit font-lock-comment-face))) + "Face used for buttons toggling the visibility of washed away +message parts." + :group 'notmuch-wash + :group 'notmuch-faces) + +(defface notmuch-wash-cited-text + '((t (:inherit message-cited-text))) + "Face used for cited text." + :group 'notmuch-wash + :group 'notmuch-faces) + +;;; Buttons + +(defun notmuch-wash-toggle-invisible-action (cite-button) + ;; Toggle overlay visibility + (let ((overlay (button-get cite-button 'overlay))) + (overlay-put overlay 'invisible (not (overlay-get overlay 'invisible)))) + ;; Update button text + (let* ((new-start (button-start cite-button)) + (overlay (button-get cite-button 'overlay)) + (button-label (notmuch-wash-button-label overlay)) + (old-point (point)) + (properties (text-properties-at (point))) + (inhibit-read-only t)) + (goto-char new-start) + (insert button-label) + (set-text-properties new-start (point) properties) + (let ((old-end (button-end cite-button))) + (move-overlay cite-button new-start (point)) + (delete-region (point) old-end)) + (goto-char (min old-point (1- (button-end cite-button)))))) + +(define-button-type 'notmuch-wash-button-invisibility-toggle-type + 'action 'notmuch-wash-toggle-invisible-action + 'follow-link t + 'face 'notmuch-wash-toggle-button + :supertype 'notmuch-button-type) + +(define-button-type 'notmuch-wash-button-citation-toggle-type + 'help-echo "mouse-1, RET: Show citation" + :supertype 'notmuch-wash-button-invisibility-toggle-type) + +(define-button-type 'notmuch-wash-button-signature-toggle-type + 'help-echo "mouse-1, RET: Show signature" + :supertype 'notmuch-wash-button-invisibility-toggle-type) + +(define-button-type 'notmuch-wash-button-original-toggle-type + 'help-echo "mouse-1, RET: Show original message" + :supertype 'notmuch-wash-button-invisibility-toggle-type) + +(defun notmuch-wash-region-isearch-show (overlay) + (notmuch-wash-toggle-invisible-action + (overlay-get overlay 'notmuch-wash-button))) + +(defun notmuch-wash-button-label (overlay) + (let* ((type (overlay-get overlay 'type)) + (invis-spec (overlay-get overlay 'invisible)) + (state (if (invisible-p invis-spec) "hidden" "visible")) + (label-format (symbol-value + (intern-soft + (format "notmuch-wash-button-%s-%s-format" + type state)))) + (lines-count (count-lines (overlay-start overlay) + (overlay-end overlay)))) + (format label-format lines-count))) + +(defun notmuch-wash-region-to-button (beg end type &optional prefix) + "Auxiliary function to do the actual making of overlays and buttons. + +BEG and END are buffer locations. TYPE should a string, either +\"citation\" or \"signature\". Optional PREFIX is some arbitrary +text to insert before the button, probably for indentation. Note +that PREFIX should not include a newline." + ;; This uses some slightly tricky conversions between strings and + ;; symbols because of the way the button code works. Note that + ;; replacing intern-soft with make-symbol will cause this to fail, + ;; since the newly created symbol has no plist. + (let ((overlay (make-overlay beg end)) + (button-type (intern-soft (concat "notmuch-wash-button-" + type "-toggle-type")))) + (overlay-put overlay 'invisible t) + (overlay-put overlay 'isearch-open-invisible #'notmuch-wash-region-isearch-show) + (overlay-put overlay 'type type) + (goto-char (1+ end)) + (save-excursion + (goto-char beg) + (when prefix + (insert-before-markers prefix)) + (let ((button-beg (point))) + (insert-before-markers (notmuch-wash-button-label overlay) "\n") + (let ((button (make-button button-beg (1- (point)) + 'overlay overlay + :type button-type))) + (overlay-put overlay 'notmuch-wash-button button)))))) + +;;; Hook functions + +(defun notmuch-wash-excerpt-citations (_msg _depth) + "Excerpt citations and up to one signature." + (goto-char (point-min)) + (beginning-of-line) + (when (and (< (point) (point-max)) + (re-search-forward notmuch-wash-original-regexp nil t)) + (notmuch-wash-region-to-button (match-beginning 0) + (point-max) + "original")) + (while (and (< (point) (point-max)) + (re-search-forward notmuch-wash-citation-regexp nil t)) + (let* ((cite-start (match-beginning 0)) + (cite-end (match-end 0)) + (cite-lines (count-lines cite-start cite-end))) + (overlay-put (make-overlay cite-start cite-end) + 'face 'notmuch-wash-cited-text) + (when (> cite-lines (+ notmuch-wash-citation-lines-prefix + notmuch-wash-citation-lines-suffix + 1)) + (goto-char cite-start) + (forward-line notmuch-wash-citation-lines-prefix) + (let ((hidden-start (point-marker))) + (goto-char cite-end) + (forward-line (- notmuch-wash-citation-lines-suffix)) + (notmuch-wash-region-to-button + hidden-start (point-marker) + "citation"))))) + (when (and (not (eobp)) + (re-search-forward notmuch-wash-signature-regexp nil t)) + (let ((sig-start (match-beginning 0))) + (when (<= (count-lines sig-start (point-max)) + notmuch-wash-signature-lines-max) + (let ((sig-start-marker (make-marker)) + (sig-end-marker (make-marker))) + (set-marker sig-start-marker sig-start) + (set-marker sig-end-marker (point-max)) + (overlay-put (make-overlay sig-start-marker sig-end-marker) + 'face 'message-cited-text) + (notmuch-wash-region-to-button + sig-start-marker sig-end-marker + "signature")))))) + +(defun notmuch-wash-elide-blank-lines (_msg _depth) + "Elide leading, trailing and successive blank lines." + ;; Algorithm derived from `article-strip-multiple-blank-lines' in + ;; `gnus-art.el'. + ;; Make all blank lines empty. + (goto-char (point-min)) + (while (re-search-forward "^[[:space:]\t]+$" nil t) + (replace-match "" nil t)) + ;; Replace multiple empty lines with a single empty line. + (goto-char (point-min)) + (while (re-search-forward "^\n\\(\n+\\)" nil t) + (delete-region (match-beginning 1) (match-end 1))) + ;; Remove a leading blank line. + (goto-char (point-min)) + (when (looking-at "\n") + (delete-region (match-beginning 0) (match-end 0))) + ;; Remove a trailing blank line. + (goto-char (point-max)) + (when (looking-at "\n") + (delete-region (match-beginning 0) (match-end 0)))) + +(defun notmuch-wash-tidy-citations (_msg _depth) + "Improve the display of cited regions of a message. + +Perform several transformations on the message body: + +- Remove lines of repeated citation leaders with no other + content, +- Remove citation leaders standing alone before a block of cited + text, +- Remove citation trailers standing alone after a block of cited + text." + ;; Remove lines of repeated citation leaders with no other content. + (goto-char (point-min)) + (while (re-search-forward "\\(^>[> ]*\n\\)\\{2,\\}" nil t) + (replace-match "\\1")) + ;; Remove citation leaders standing alone before a block of cited text. + (goto-char (point-min)) + (while (re-search-forward "\\(\n\\|^[^>].*\\)\n\\(^>[> ]*\n\\)" nil t) + (replace-match "\\1\n")) + ;; Remove citation trailers standing alone after a block of cited text. + (goto-char (point-min)) + (while (re-search-forward "\\(^>[> ]*\n\\)\\(^$\\|^[^>].*\\)" nil t) + (replace-match "\\2"))) + +(defun notmuch-wash-wrap-long-lines (_msg depth) + "Wrap long lines in the message. + +If `notmuch-wash-wrap-lines-length' is a number, this will wrap +the message lines to the minimum of the width of the window or +its value. Otherwise, this function will wrap long lines in the +message at the window width. When doing so, citation leaders in +the wrapped text are maintained." + (let* ((coolj-wrap-follows-window-size nil) + (indent (* depth notmuch-show-indent-messages-width)) + (limit (if (numberp notmuch-wash-wrap-lines-length) + (min (+ notmuch-wash-wrap-lines-length indent) + (window-width)) + (window-width))) + (fill-column (- limit + indent + ;; 2 to avoid poor interaction with + ;; `word-wrap'. + 2))) + (coolj-wrap-region (point-min) (point-max)))) + +;;;; Convert Inline Patches + +(defun notmuch-wash-subject-to-filename (subject &optional maxlen) + "Convert a mail SUBJECT into a filename. + +The resulting filename is similar to the names generated by \"git +format-patch\", without the leading patch sequence number +\"0001-\" and \".patch\" extension. Any leading \"[PREFIX]\" +style strings are removed prior to conversion. + +Optional argument MAXLEN is the maximum length of the resulting +filename, before trimming any trailing . and - characters." + (let* ((s (replace-regexp-in-string "^ *\\(\\[[^]]*\\] *\\)*" "" subject)) + (s (replace-regexp-in-string "[^A-Za-z0-9._]+" "-" s)) + (s (replace-regexp-in-string "\\.+" "." s)) + (s (if maxlen (substring s 0 (min (length s) maxlen)) s)) + (s (replace-regexp-in-string "[.-]*$" "" s))) + s)) + +(defun notmuch-wash-subject-to-patch-sequence-number (subject) + "Convert a patch mail SUBJECT into a patch sequence number. + +Return the patch sequence number N from the last \"[PATCH N/M]\" +style prefix in SUBJECT, or nil if such a prefix can't be found." + (and (string-match + "^ *\\(\\[[^]]*\\] *\\)*\\[[^]]*?\\([0-9]+\\)/[0-9]+[^]]*\\].*" + subject) + (string-to-number (substring subject (match-beginning 2) (match-end 2))))) + +(defun notmuch-wash-subject-to-patch-filename (subject) + "Convert a patch mail SUBJECT into a filename. + +The resulting filename is similar to the names generated by \"git +format-patch\". If the patch mail was generated and sent using +\"git format-patch/send-email\", this should re-create the +original filename the sender had." + (format "%04d-%s.patch" + (or (notmuch-wash-subject-to-patch-sequence-number subject) 1) + (notmuch-wash-subject-to-filename subject 52))) + +(defun notmuch-wash-convert-inline-patch-to-part (msg depth) + "Convert an inline patch into a fake `text/x-diff' attachment. + +Given that this function guesses whether a buffer includes a +patch and then guesses the extent of the patch, there is scope +for error." + (goto-char (point-min)) + (when (re-search-forward diff-file-header-re nil t) + (beginning-of-line -1) + (let ((patch-start (point)) + (patch-end (point-max)) + part) + (goto-char patch-start) + (when (or + ;; Patch ends with signature. + (re-search-forward notmuch-wash-signature-regexp nil t) + ;; Patch ends with bugtraq comment. + (re-search-forward "^\\*\\*\\* " nil t)) + (setq patch-end (match-beginning 0))) + (save-restriction + (narrow-to-region patch-start patch-end) + (setq part (plist-put part :content-type "inline patch")) + (setq part (plist-put part :content (buffer-string))) + (setq part (plist-put part :id -1)) + (setq part (plist-put part :filename + (notmuch-wash-subject-to-patch-filename + (plist-get + (plist-get msg :headers) :Subject)))) + (delete-region (point-min) (point-max)) + (notmuch-show-insert-bodypart nil part depth))))) + +;;; _ + +(provide 'notmuch-wash) + +;;; notmuch-wash.el ends here blob - /dev/null blob + f36f24c49d822201584be968b1480e09fa0c7bb6 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/notmuch.el @@ -0,0 +1,1287 @@ +;;; notmuch.el --- run notmuch within emacs -*- lexical-binding: t -*- +;; +;; Copyright © Carl Worth +;; +;; This file is part of Notmuch. +;; +;; Notmuch 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 3 of the License, or +;; (at your option) any later version. +;; +;; Notmuch 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 Notmuch. If not, see . +;; +;; Authors: Carl Worth +;; Package-Version: 0.39 +;; Package-Revision: 0.39-0-ga5214eabb63b +;; Homepage: https://notmuchmail.org + +;;; Commentary: + +;; This is an emacs-based interface to the notmuch mail system. +;; +;; You will first need to have the notmuch program installed and have a +;; notmuch database built in order to use this. See +;; https://notmuchmail.org for details. +;; +;; To install this software, copy it to a directory that is on the +;; `load-path' variable within emacs (a good candidate is +;; /usr/local/share/emacs/site-lisp). If you are viewing this from the +;; notmuch source distribution then you can simply run: +;; +;; sudo make install-emacs +;; +;; to install it. +;; +;; Then, to actually run it, add: +;; +;; (autoload 'notmuch "notmuch" "Notmuch mail" t) +;; +;; to your ~/.emacs file, and then run "M-x notmuch" from within emacs, +;; or run: +;; +;; emacs -f notmuch +;; +;; Have fun, and let us know if you have any comment, questions, or +;; kudos: Notmuch list (subscription is not +;; required, but is available from https://notmuchmail.org). +;; +;; Note for MELPA users (and others tracking the development version +;; of notmuch-emacs): +;; +;; This emacs package needs a fairly closely matched version of the +;; notmuch program. If you use the MELPA version of notmuch.el (as +;; opposed to MELPA stable), you should be prepared to track the +;; master development branch (i.e. build from git) for the notmuch +;; program as well. Upgrading notmuch-emacs too far beyond the notmuch +;; program can CAUSE YOUR EMAIL TO STOP WORKING. +;; +;; TL;DR: notmuch-emacs from MELPA and notmuch from distro packages is +;; NOT SUPPORTED. + +;;; Code: + +(require 'mm-view) +(require 'message) + +(require 'hl-line) + +(require 'notmuch-lib) +(require 'notmuch-tag) +(require 'notmuch-show) +(require 'notmuch-tree) +(require 'notmuch-mua) +(require 'notmuch-hello) +(require 'notmuch-maildir-fcc) +(require 'notmuch-message) +(require 'notmuch-parser) + +;;; Options + +(defcustom notmuch-search-result-format + `(("date" . "%12s ") + ("count" . "%-7s ") + ("authors" . "%-20s ") + ("subject" . "%s ") + ("tags" . "(%s)")) + "Search result formatting. + +List of pairs of (field . format-string). Supported field +strings are: \"date\", \"count\", \"authors\", \"subject\", +\"tags\". It is also supported to pass a function in place of a +field name. In this case the function is passed the thread +object (plist) and format string. + +Line breaks are permitted in format strings (though this is +currently experimental). Note that a line break at the end of an +\"authors\" field will get elided if the authors list is long; +place it instead at the beginning of the following field. To +enter a line break when setting this variable with setq, use \\n. +To enter a line break in customize, press \\[quoted-insert] C-j." + :type '(alist + :key-type + (choice + (const :tag "Date" "date") + (const :tag "Count" "count") + (const :tag "Authors" "authors") + (const :tag "Subject" "subject") + (const :tag "Tags" "tags") + function) + :value-type (string :tag "Format")) + :group 'notmuch-search) + +;; The name of this variable `notmuch-init-file' is consistent with the +;; convention used in e.g. emacs and gnus. The value, `notmuch-config[.el[c]]' +;; is consistent with notmuch cli configuration file `~/.notmuch-config'. +(defcustom notmuch-init-file (locate-user-emacs-file "notmuch-config") + "Your Notmuch Emacs-Lisp configuration file name. +If a file with one of the suffixes defined by `get-load-suffixes' exists, +it will be read instead. +This file is read once when notmuch is loaded; the notmuch hooks added +there will be called at other points of notmuch execution." + :type 'file + :group 'notmuch) + +(defcustom notmuch-search-hook nil + "List of functions to call when notmuch displays the search results." + :type 'hook + :group 'notmuch-search + :group 'notmuch-hooks) + +(defcustom notmuch-hl-line t + "Use hl-line-mode to highlight current thread / message" + :type 'boolean + :group 'notmuch) + +;;; Mime Utilities + +(defun notmuch-foreach-mime-part (function mm-handle) + (cond ((stringp (car mm-handle)) + (dolist (part (cdr mm-handle)) + (notmuch-foreach-mime-part function part))) + ((bufferp (car mm-handle)) + (funcall function mm-handle)) + (t (dolist (part mm-handle) + (notmuch-foreach-mime-part function part))))) + +(defun notmuch-count-attachments (mm-handle) + (let ((count 0)) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (cl-incf count)))) + mm-handle) + count)) + +(defun notmuch-save-attachments (mm-handle &optional queryp) + (notmuch-foreach-mime-part + (lambda (p) + (let ((disposition (mm-handle-disposition p))) + (and (listp disposition) + (or (equal (car disposition) "attachment") + (and (equal (car disposition) "inline") + (assq 'filename disposition))) + (or (not queryp) + (y-or-n-p + (concat "Save '" (cdr (assq 'filename disposition)) "' "))) + (mm-save-part p)))) + mm-handle)) + +;;; Keymap + +(defvar notmuch-search-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map notmuch-common-keymap) + (define-key map "x" 'notmuch-bury-or-kill-this-buffer) + (define-key map (kbd "DEL") 'notmuch-search-scroll-down) + (define-key map "b" 'notmuch-search-scroll-down) + (define-key map " " 'notmuch-search-scroll-up) + (define-key map "<" 'notmuch-search-first-thread) + (define-key map ">" 'notmuch-search-last-thread) + (define-key map "p" 'notmuch-search-previous-thread) + (define-key map "n" 'notmuch-search-next-thread) + (define-key map "r" 'notmuch-search-reply-to-thread-sender) + (define-key map "R" 'notmuch-search-reply-to-thread) + (define-key map "o" 'notmuch-search-toggle-order) + (define-key map "i" 'notmuch-search-toggle-hide-excluded) + (define-key map "c" 'notmuch-search-stash-map) + (define-key map "t" 'notmuch-search-filter-by-tag) + (define-key map "l" 'notmuch-search-filter) + (define-key map "E" 'notmuch-search-edit-search) + (define-key map [mouse-1] 'notmuch-search-show-thread) + (define-key map "k" 'notmuch-tag-jump) + (define-key map "*" 'notmuch-search-tag-all) + (define-key map "a" 'notmuch-search-archive-thread) + (define-key map "-" 'notmuch-search-remove-tag) + (define-key map "+" 'notmuch-search-add-tag) + (define-key map (kbd "RET") 'notmuch-search-show-thread) + (define-key map (kbd "M-RET") 'notmuch-tree-from-search-thread) + (define-key map "Z" 'notmuch-tree-from-search-current-query) + (define-key map "U" 'notmuch-unthreaded-from-search-current-query) + map) + "Keymap for \"notmuch search\" buffers.") + +;;; Internal Variables + +(defvar notmuch-query-history nil + "Variable to store minibuffer history for notmuch queries.") + +(defvar-local notmuch-search-query-string nil) +(defvar-local notmuch-search-target-thread nil) +(defvar-local notmuch-search-target-line nil) + +;;; Stashing + +(defvar notmuch-search-stash-map + (let ((map (make-sparse-keymap))) + (define-key map "i" 'notmuch-search-stash-thread-id) + (define-key map "q" 'notmuch-stash-query) + (define-key map "?" 'notmuch-subkeymap-help) + map) + "Submap for stash commands.") +(fset 'notmuch-search-stash-map notmuch-search-stash-map) + +(defun notmuch-search-stash-thread-id () + "Copy thread ID of current thread to kill-ring." + (interactive) + (notmuch-common-do-stash (notmuch-search-find-thread-id))) + +(defun notmuch-stash-query () + "Copy current query to kill-ring." + (interactive) + (notmuch-common-do-stash notmuch-search-query-string)) + +;;; Movement + +(defun notmuch-search-scroll-up () + "Move forward through search results by one window's worth." + (interactive) + (condition-case nil + (scroll-up nil) + ((end-of-buffer) (notmuch-search-last-thread)))) + +(defun notmuch-search-scroll-down () + "Move backward through the search results by one window's worth." + (interactive) + ;; I don't know why scroll-down doesn't signal beginning-of-buffer + ;; the way that scroll-up signals end-of-buffer, but c'est la vie. + ;; + ;; So instead of trapping a signal we instead check whether the + ;; window begins on the first line of the buffer and if so, move + ;; directly to that position. (We have to count lines since the + ;; window-start position is not the same as point-min due to the + ;; invisible thread-ID characters on the first line. + (if (equal (count-lines (point-min) (window-start)) 0) + (goto-char (point-min)) + (scroll-down nil))) + +(defun notmuch-search-next-thread () + "Select the next thread in the search results." + (interactive) + (when (notmuch-search-get-result) + (goto-char (notmuch-search-result-end)))) + +(defun notmuch-search-previous-thread () + "Select the previous thread in the search results." + (interactive) + (if (notmuch-search-get-result) + (unless (bobp) + (goto-char (notmuch-search-result-beginning (- (point) 1)))) + ;; We must be past the end; jump to the last result + (notmuch-search-last-thread))) + +(defun notmuch-search-last-thread () + "Select the last thread in the search results." + (interactive) + (goto-char (point-max)) + (forward-line -2) + (let ((beg (notmuch-search-result-beginning))) + (when beg + (goto-char beg)))) + +(defun notmuch-search-first-thread () + "Select the first thread in the search results." + (interactive) + (goto-char (point-min))) + +;;; Faces + +(defface notmuch-message-summary-face + `((((class color) (background light)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#f0f0f0") + (((class color) (background dark)) + ,@(and (>= emacs-major-version 27) '(:extend t)) + :background "#303030")) + "Face for the single-line message summary in notmuch-show-mode." + :group 'notmuch-show + :group 'notmuch-faces) + +(defface notmuch-search-date + '((t :inherit default)) + "Face used in search mode for dates." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-count + '((t :inherit default)) + "Face used in search mode for the count matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-subject + '((t :inherit default)) + "Face used in search mode for subjects." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-matching-authors + '((t :inherit default)) + "Face used in search mode for authors matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-non-matching-authors + '((((class color) + (background dark)) + (:foreground "grey30")) + (((class color) + (background light)) + (:foreground "grey60")) + (t + (:italic t))) + "Face used in search mode for authors not matching the query." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-tag-face + '((((class color) + (background dark)) + (:foreground "OliveDrab1")) + (((class color) + (background light)) + (:foreground "navy blue" :bold t)) + (t + (:bold t))) + "Face used in search mode face for tags." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-flagged-face + '((((class color) + (background dark)) + (:foreground "LightBlue1")) + (((class color) + (background light)) + (:foreground "blue"))) + "Face used in search mode face for flagged threads. + +This face is the default value for the \"flagged\" tag in +`notmuch-search-line-faces'." + :group 'notmuch-search + :group 'notmuch-faces) + +(defface notmuch-search-unread-face + '((t + (:weight bold))) + "Face used in search mode for unread threads. + +This face is the default value for the \"unread\" tag in +`notmuch-search-line-faces'." + :group 'notmuch-search + :group 'notmuch-faces) + +;;; Mode + +(define-derived-mode notmuch-search-mode fundamental-mode "notmuch-search" + "Major mode displaying results of a notmuch search. + +This buffer contains the results of a \"notmuch search\" of your +email archives. Each line in the buffer represents a single +thread giving a summary of the thread (a relative date, the +number of matched messages and total messages in the thread, +participants in the thread, a representative subject line, and +any tags). + +Pressing \\[notmuch-search-show-thread] on any line displays that +thread. The '\\[notmuch-search-add-tag]' and +'\\[notmuch-search-remove-tag]' keys can be used to add or remove +tags from a thread. The '\\[notmuch-search-archive-thread]' key +is a convenience for archiving a thread (applying changes in +`notmuch-archive-tags'). The '\\[notmuch-search-tag-all]' key can +be used to add and/or remove tags from all messages (as opposed +to threads) that match the current query. Use with caution, as +this will also tag matching messages that arrived *after* +constructing the buffer. + +Other useful commands are '\\[notmuch-search-filter]' for +filtering the current search based on an additional query string, +'\\[notmuch-search-filter-by-tag]' for filtering to include only +messages with a given tag, and '\\[notmuch-search]' to execute a +new, global search. + +Complete list of currently available key bindings: + +\\{notmuch-search-mode-map}" + (setq notmuch-buffer-refresh-function #'notmuch-search-refresh-view) + (setq-local scroll-preserve-screen-position t) + (add-to-invisibility-spec (cons 'ellipsis t)) + (setq truncate-lines t) + (setq buffer-read-only t) + (when (boundp 'untrusted-content) + (setq untrusted-content t)) + (setq imenu-prev-index-position-function + #'notmuch-search-imenu-prev-index-position-function) + (setq imenu-extract-index-name-function + #'notmuch-search-imenu-extract-index-name-function)) + +;;; Search Results + +(defun notmuch-search-get-result (&optional pos) + "Return the result object for the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (get-text-property (or pos (point)) 'notmuch-search-result)) + +(defun notmuch-search-result-beginning (&optional pos) + "Return the point at the beginning of the thread at POS (or point). + +If there is no thread at POS (or point), returns nil." + (and (notmuch-search-get-result pos) + ;; We pass 1+point because previous-single-property-change starts + ;; searching one before the position we give it. + (previous-single-property-change (1+ (or pos (point))) + 'notmuch-search-result nil + (point-min)))) + +(defun notmuch-search-result-end (&optional pos) + "Return the point at the end of the thread at POS (or point). + +The returned point will be just after the newline character that +ends the result line. If there is no thread at POS (or point), +returns nil." + (and (notmuch-search-get-result pos) + (next-single-property-change (or pos (point)) + 'notmuch-search-result nil + (point-max)))) + +(defun notmuch-search-foreach-result (beg end fn) + "Invoke FN for each result between BEG and END. + +FN should take one argument. It will be applied to the character +position of the beginning of each result that overlaps the region +between points BEG and END. As a special case, if (= BEG END), +FN will be applied to the result containing point BEG." + (let ((pos (notmuch-search-result-beginning beg)) + ;; End must be a marker in case fn changes the + ;; text. + (end (copy-marker end)) + ;; Make sure we examine at least one result, even if + ;; (= beg end). + (first t)) + ;; We have to be careful if the region extends beyond the results. + ;; In this case, pos could be null or there could be no result at + ;; pos. + (while (and pos (or (< pos end) first)) + (when (notmuch-search-get-result pos) + (funcall fn pos)) + (setq pos (notmuch-search-result-end pos)) + (setq first nil)))) +;; Unindent the function argument of notmuch-search-foreach-result so +;; the indentation of callers doesn't get out of hand. +(put 'notmuch-search-foreach-result 'lisp-indent-function 2) + +(defun notmuch-search-properties-in-region (property beg end) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (push (plist-get (notmuch-search-get-result pos) property) output))) + output)) + +(defun notmuch-search-find-thread-id (&optional bare) + "Return the thread for the current thread. + +If BARE is set then do not prefix with \"thread:\"." + (let ((thread (plist-get (notmuch-search-get-result) :thread))) + (when thread + (concat (and (not bare) "thread:") thread)))) + +(defun notmuch-search-find-stable-query () + "Return the stable queries for the current thread. + +Return a list (MATCHED-QUERY UNMATCHED-QUERY) for the +matched and unmatched messages in the current thread." + (plist-get (notmuch-search-get-result) :query)) + +(defun notmuch-search-find-stable-query-region (beg end &optional only-matched) + "Return the stable query for the current region. + +If ONLY-MATCHED is non-nil, include only matched messages. If it +is nil, include both matched and unmatched messages. If there are +no messages in the region then return nil." + (let ((query-list nil) (all (not only-matched))) + (dolist (queries (notmuch-search-properties-in-region :query beg end)) + (when (car queries) + (push (car queries) query-list)) + (when (and all (cadr queries)) + (push (cadr queries) query-list))) + (and query-list + (concat "(" (mapconcat 'identity query-list ") or (") ")")))) + +(defun notmuch-search-find-authors () + "Return the authors for the current thread." + (plist-get (notmuch-search-get-result) :authors)) + +(defun notmuch-search-find-authors-region (beg end) + "Return a list of authors for the current region." + (notmuch-search-properties-in-region :authors beg end)) + +(defun notmuch-search-find-subject () + "Return the subject for the current thread." + (plist-get (notmuch-search-get-result) :subject)) + +(defun notmuch-search-find-subject-region (beg end) + "Return a list of authors for the current region." + (notmuch-search-properties-in-region :subject beg end)) + +(defun notmuch-search-show-thread (&optional elide-toggle) + "Display the currently selected thread. + +With a prefix argument, invert the default value of +`notmuch-show-only-matching-messages' when displaying the +thread. + +Return non-nil on success." + (interactive "P") + (let ((thread-id (notmuch-search-find-thread-id))) + (if thread-id + (notmuch-show thread-id + elide-toggle + (current-buffer) + notmuch-search-query-string + ;; Name the buffer based on the subject. + (format "*%s*" (truncate-string-to-width + (notmuch-search-find-subject) + 30 nil nil t))) + (message "End of search results.") + nil))) + +(defun notmuch-tree-from-search-current-query () + "Tree view of current query." + (interactive) + (notmuch-tree notmuch-search-query-string + nil nil nil nil nil nil + notmuch-search-oldest-first + notmuch-search-hide-excluded)) + +(defun notmuch-unthreaded-from-search-current-query () + "Unthreaded view of current query." + (interactive) + (notmuch-unthreaded notmuch-search-query-string + nil nil nil nil + notmuch-search-oldest-first + notmuch-search-hide-excluded)) + +(defun notmuch-tree-from-search-thread () + "Show the selected thread with notmuch-tree." + (interactive) + (notmuch-tree (notmuch-search-find-thread-id) + notmuch-search-query-string + nil + (notmuch-prettify-subject (notmuch-search-find-subject)) + t nil (current-buffer) + notmuch-search-oldest-first + notmuch-search-hide-excluded)) + +(defun notmuch-search-reply-to-thread (&optional prompt-for-sender) + "Begin composing a reply-all to the entire current thread in a new buffer." + (interactive "P") + (notmuch-mua-new-reply (notmuch-search-find-thread-id) + prompt-for-sender t)) + +(defun notmuch-search-reply-to-thread-sender (&optional prompt-for-sender) + "Begin composing a reply to the entire current thread in a new buffer." + (interactive "P") + (notmuch-mua-new-reply (notmuch-search-find-thread-id) + prompt-for-sender nil)) + +;;; Tags + +(defun notmuch-search-set-tags (tags &optional pos) + (notmuch-search-update-result + (plist-put (notmuch-search-get-result pos) :tags tags) + pos)) + +(defun notmuch-search-get-tags (&optional pos) + (plist-get (notmuch-search-get-result pos) :tags)) + +(defun notmuch-search-get-tags-region (beg end) + (let (output) + (notmuch-search-foreach-result beg end + (lambda (pos) + (setq output (append output (notmuch-search-get-tags pos))))) + (delete-dups output))) + +(defun notmuch-search-interactive-tag-changes (&optional initial-input) + "Prompt for tag changes for the current thread or region. + +Return (TAG-CHANGES REGION-BEGIN REGION-END)." + (pcase-let ((`(,beg ,end) (notmuch-interactive-region))) + (list (notmuch-read-tag-changes (notmuch-search-get-tags-region beg end) + (if (= beg end) "Tag thread" "Tag region") + initial-input) + beg end))) + +(defun notmuch-search-tag (tag-changes &optional beg end only-matched) + "Change tags for the currently selected thread or region. + +See `notmuch-tag' for information on the format of TAG-CHANGES. +When called interactively, this uses the region if the region is +active. When called directly, BEG and END provide the region. +If these are nil or not provided, then, if the region is active +this applied to all threads meeting the region, and if the region +is inactive this applies to the thread at point. + +If ONLY-MATCHED is non-nil, only tag matched messages." + (interactive (notmuch-search-interactive-tag-changes)) + (unless (and beg end) + (setq beg (car (notmuch-interactive-region))) + (setq end (cadr (notmuch-interactive-region)))) + (let ((search-string (notmuch-search-find-stable-query-region + beg end only-matched))) + (notmuch-tag search-string tag-changes) + (notmuch-search-foreach-result beg end + (lambda (pos) + (notmuch-search-set-tags + (notmuch-update-tags (notmuch-search-get-tags pos) tag-changes) + pos))))) + +(defun notmuch-search-add-tag (tag-changes &optional beg end) + "Change tags for the current thread or region (defaulting to add). + +Same as `notmuch-search-tag' but sets initial input to '+'." + (interactive (notmuch-search-interactive-tag-changes "+")) + (notmuch-search-tag tag-changes beg end)) + +(defun notmuch-search-remove-tag (tag-changes &optional beg end) + "Change tags for the current thread or region (defaulting to remove). + +Same as `notmuch-search-tag' but sets initial input to '-'." + (interactive (notmuch-search-interactive-tag-changes "-")) + (notmuch-search-tag tag-changes beg end)) + +(put 'notmuch-search-archive-thread 'notmuch-prefix-doc + "Un-archive the currently selected thread.") +(defun notmuch-search-archive-thread (&optional unarchive beg end) + "Archive the currently selected thread or region. + +Archive each message in the currently selected thread by applying +the tag changes in `notmuch-archive-tags' to each (remove the +\"inbox\" tag by default). If a prefix argument is given, the +messages will be \"unarchived\" (i.e. the tag changes in +`notmuch-archive-tags' will be reversed). + +This function advances the next thread when finished." + (interactive (cons current-prefix-arg (notmuch-interactive-region))) + (when notmuch-archive-tags + (notmuch-search-tag + (notmuch-tag-change-list notmuch-archive-tags unarchive) beg end)) + (when (eq beg end) + (notmuch-search-next-thread))) + +;;; Search Results + +(defun notmuch-search-update-result (result &optional pos) + "Replace the result object of the thread at POS (or point) by +RESULT and redraw it. + +This will keep point in a reasonable location. However, if there +are enclosing save-excursions and the saved point is in the +result being updated, the point will be restored to the beginning +of the result." + (let ((start (notmuch-search-result-beginning pos)) + (end (notmuch-search-result-end pos)) + (init-point (point)) + (inhibit-read-only t)) + ;; Delete the current thread + (delete-region start end) + ;; Insert the updated thread + (notmuch-search-show-result result start) + ;; If point was inside the old result, make an educated guess + ;; about where to place it now. Unfortunately, this won't work + ;; with save-excursion (or any other markers that would be nice to + ;; preserve, such as the window start), but there's nothing we can + ;; do about that without a way to retrieve markers in a region. + (when (and (>= init-point start) (<= init-point end)) + (let* ((new-end (notmuch-search-result-end start)) + (new-point (if (= init-point end) + new-end + (min init-point (- new-end 1))))) + (goto-char new-point))))) + +(defun notmuch-search-process-sentinel (proc _msg) + "Add a message to let user know when \"notmuch search\" exits." + (let ((buffer (process-buffer proc)) + (status (process-status proc)) + (exit-status (process-exit-status proc)) + (never-found-target-thread nil)) + (when (memq status '(exit signal)) + (catch 'return + (kill-buffer (process-get proc 'parse-buf)) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (let ((inhibit-read-only t) + (atbob (bobp))) + (goto-char (point-max)) + (when (eq status 'signal) + (insert "Incomplete search results (search process was killed).\n")) + (when (eq status 'exit) + (insert "End of search results.\n") + ;; For version mismatch, there's no point in + ;; showing the search buffer + (when (or (= exit-status 20) (= exit-status 21)) + (kill-buffer) + (throw 'return nil)) + (when (and atbob + (not (string= notmuch-search-target-thread "found"))) + (setq never-found-target-thread t))))) + (when (and never-found-target-thread + notmuch-search-target-line) + (goto-char (point-min)) + (forward-line (1- notmuch-search-target-line))))))))) + +(define-widget 'notmuch--custom-face-edit 'lazy + "Custom face edit with a tag Edit Face" + ;; I could not persuage custom-face-edit to respect the :tag + ;; property so create a widget specially + :tag "Manually specify face" + :type 'custom-face-edit) + +(defcustom notmuch-search-line-faces + '(("unread" . notmuch-search-unread-face) + ("flagged" . notmuch-search-flagged-face)) + "Alist of tags to faces for line highlighting in notmuch-search. +Each element looks like (TAG . FACE). +A thread with TAG will have FACE applied. + +Here is an example of how to color search results based on tags. + (the following text would be placed in your ~/.emacs file): + + (setq notmuch-search-line-faces \\='((\"unread\" . (:foreground \"green\")) + (\"deleted\" . (:foreground \"red\" + :background \"blue\")))) + +The FACE must be a face name (a symbol or string), a property +list of face attributes, or a list of these. The faces for +matching tags are merged, with earlier attributes overriding +later. A message having both \"deleted\" and \"unread\" tags with +the above settings would have a green foreground and blue +background." + :type '(alist :key-type (string) + :value-type (radio (face :tag "Face name") + (notmuch--custom-face-edit))) + :group 'notmuch-search + :group 'notmuch-faces) + +(defun notmuch-search-color-line (start end line-tag-list) + "Colorize lines in `notmuch-show' based on tags." + ;; Reverse the list so earlier entries take precedence + (dolist (elem (reverse notmuch-search-line-faces)) + (let ((tag (car elem)) + (face (cdr elem))) + (when (member tag line-tag-list) + (notmuch-apply-face nil face nil start end))))) + +(defun notmuch-search-author-propertize (authors) + "Split `authors' into matching and non-matching authors and +propertize appropriately. If no boundary between authors and +non-authors is found, assume that all of the authors match." + (if (string-match "\\(.*\\)|\\(.*\\)" authors) + (concat (propertize (concat (match-string 1 authors) ",") + 'face 'notmuch-search-matching-authors) + (propertize (match-string 2 authors) + 'face 'notmuch-search-non-matching-authors)) + (propertize authors 'face 'notmuch-search-matching-authors))) + +(defun notmuch-search-insert-authors (format-string authors) + ;; Save the match data to avoid interfering with + ;; `notmuch-search-process-filter'. + (save-match-data + (let* ((formatted-authors (format format-string authors)) + (formatted-sample (format format-string "")) + (visible-string formatted-authors) + (invisible-string "") + (padding "")) + ;; Truncate the author string to fit the specification. + (when (> (length formatted-authors) + (length formatted-sample)) + (let ((visible-length (- (length formatted-sample) + (length "... ")))) + ;; Truncate the visible string according to the width of + ;; the display string. + (setq visible-string (substring formatted-authors 0 visible-length)) + (setq invisible-string (substring formatted-authors visible-length)) + ;; If possible, truncate the visible string at a natural + ;; break (comma or pipe), as incremental search doesn't + ;; match across the visible/invisible border. + (when (string-match "\\(.*\\)\\([,|] \\)\\([^,|]*\\)" visible-string) + ;; Second clause is destructive on `visible-string', so + ;; order is important. + (setq invisible-string (concat (match-string 3 visible-string) + invisible-string)) + (setq visible-string (concat (match-string 1 visible-string) + (match-string 2 visible-string)))) + ;; `visible-string' may be shorter than the space allowed + ;; by `format-string'. If so we must insert some padding + ;; after `invisible-string'. + (setq padding (make-string (- (length formatted-sample) + (length visible-string) + (length "...")) + ? )))) + ;; Use different faces to show matching and non-matching authors. + (if (string-match "\\(.*\\)|\\(.*\\)" visible-string) + ;; The visible string contains both matching and + ;; non-matching authors. + (progn + (setq visible-string (notmuch-search-author-propertize visible-string)) + ;; The invisible string must contain only non-matching + ;; authors, as the visible-string contains both. + (setq invisible-string (propertize invisible-string + 'face 'notmuch-search-non-matching-authors))) + ;; The visible string contains only matching authors. + (setq visible-string (propertize visible-string + 'face 'notmuch-search-matching-authors)) + ;; The invisible string may contain both matching and + ;; non-matching authors. + (setq invisible-string (notmuch-search-author-propertize invisible-string))) + ;; If there is any invisible text, add it as a tooltip to the + ;; visible text. + (unless (string-empty-p invisible-string) + (setq visible-string + (propertize visible-string + 'help-echo (concat "..." invisible-string)))) + ;; Insert the visible and, if present, invisible author strings. + (insert visible-string) + (unless (string-empty-p invisible-string) + (let ((start (point)) + overlay) + (insert invisible-string) + (setq overlay (make-overlay start (point))) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'invisible 'ellipsis) + (overlay-put overlay 'isearch-open-invisible #'delete-overlay))) + (insert padding)))) + +(defun notmuch-search-insert-field (field format-string result) + (pcase field + ((pred functionp) + (insert (funcall field format-string result))) + ("date" + (insert (propertize (format format-string (plist-get result :date_relative)) + 'face 'notmuch-search-date))) + ("count" + (insert (propertize (format format-string + (format "[%s/%s]" (plist-get result :matched) + (plist-get result :total))) + 'face 'notmuch-search-count))) + ("subject" + (insert (propertize (format format-string + (notmuch-sanitize (plist-get result :subject))) + 'face 'notmuch-search-subject))) + ("authors" + (notmuch-search-insert-authors format-string + (notmuch-sanitize (plist-get result :authors)))) + ("tags" + (let ((tags (plist-get result :tags)) + (orig-tags (plist-get result :orig-tags))) + (insert (format format-string (notmuch-tag-format-tags tags orig-tags))))))) + +(defun notmuch-search-show-result (result pos) + "Insert RESULT at POS." + ;; Ignore excluded matches + (unless (= (plist-get result :matched) 0) + (save-excursion + (goto-char pos) + (dolist (spec notmuch-search-result-format) + (notmuch-search-insert-field (car spec) (cdr spec) result)) + (insert "\n") + (notmuch-search-color-line pos (point) (plist-get result :tags)) + (put-text-property pos (point) 'notmuch-search-result result)))) + +(defun notmuch-search-append-result (result) + "Insert RESULT at the end of the buffer. + +This is only called when a result is first inserted so it also +sets the :orig-tag property." + (let ((new-result (plist-put result :orig-tags (plist-get result :tags))) + (pos (point-max))) + (notmuch-search-show-result new-result pos) + (when (string= (plist-get result :thread) notmuch-search-target-thread) + (setq notmuch-search-target-thread "found") + (goto-char pos)))) + +(defvar-local notmuch--search-hook-run nil + "Flag used to ensure the notmuch-search-hook is only run once per buffer") + +(defun notmuch--search-hook-wrapper () + (unless notmuch--search-hook-run + (setq notmuch--search-hook-run t) + (run-hooks 'notmuch-search-hook))) + +(defun notmuch-search-process-filter (proc string) + "Process and filter the output of \"notmuch search\"." + (let ((results-buf (process-buffer proc)) + (parse-buf (process-get proc 'parse-buf)) + (inhibit-read-only t)) + (when (buffer-live-p results-buf) + (with-current-buffer parse-buf + ;; Insert new data + (save-excursion + (goto-char (point-max)) + (insert string)) + (notmuch-sexp-parse-partial-list 'notmuch-search-append-result + results-buf)) + (with-current-buffer results-buf + (when (and notmuch-hl-line + ;; If we know where the cursor will end up (from + ;; the call to notmuch-search), avoid redrawing the + ;; hl-line overlay until the buffer is sufficiently + ;; filled. This check is intended as an + ;; optimization to reduce flicker. + (>= + (line-number-at-pos (point-max) t) + (or notmuch-search-target-line -1))) + (notmuch-hl-line-mode)) + (notmuch--search-hook-wrapper))))) + +;;; Commands (and some helper functions used by them) + +(defun notmuch-search-tag-all (tag-changes) + "Add/remove tags from all messages in current search buffer. + +See `notmuch-tag' for information on the format of TAG-CHANGES." + (interactive + (list (notmuch-read-tag-changes + (notmuch-search-get-tags-region (point-min) (point-max)) "Tag all"))) + (notmuch-search-tag tag-changes (point-min) (point-max) t)) + +(defcustom notmuch-search-buffer-name-format "*notmuch-%t-%s*" + "Format for the name of search results buffers. + +In this spec, %s will be replaced by a description of the search +query and %t by its type (search, tree or unthreaded). The +buffer name is formatted using `format-spec': see its docstring +for additional parameters for the s and t format specifiers. + +See also `notmuch-saved-search-buffer-name-format'" + :type 'string + :group 'notmuch-search) + +(defcustom notmuch-saved-search-buffer-name-format "*notmuch-saved-%t-%s*" + "Format for the name of search results buffers for saved searches. + +In this spec, %s will be replaced by the saved search name and %t +by its type (search, tree or unthreaded). The buffer name is +formatted using `format-spec': see its docstring for additional +parameters for the s and t format specifiers. + +See also `notmuch-search-buffer-name-format'" + :type 'string + :group 'notmuch-search) + +(defun notmuch-search-format-buffer-name (query type saved) + "Compose a buffer name for the given QUERY, TYPE (search, tree, +unthreaded) and whether it's SAVED (t or nil)." + (let ((fmt (if saved + notmuch-saved-search-buffer-name-format + notmuch-search-buffer-name-format))) + (format-spec fmt `((?t . ,(or type "search")) (?s . ,query))))) + +(defun notmuch-search-buffer-title (query &optional type) + "Returns the title for a buffer with notmuch search results." + (let* ((saved-search + (let (longest + (longest-length 0)) + (cl-loop for tuple in notmuch-saved-searches + if (let ((quoted-query + (regexp-quote + (notmuch-saved-search-get tuple :query)))) + (and (string-match (concat "^" quoted-query) query) + (> (length (match-string 0 query)) + longest-length))) + do (setq longest tuple)) + longest)) + (saved-search-name (notmuch-saved-search-get saved-search :name)) + (saved-search-type (notmuch-saved-search-get saved-search :search-type)) + (saved-search-query (notmuch-saved-search-get saved-search :query))) + (cond ((and saved-search (equal saved-search-query query)) + ;; Query is the same as saved search (ignoring case) + (notmuch-search-format-buffer-name saved-search-name + saved-search-type + t)) + (saved-search + (let ((query (replace-regexp-in-string + (concat "^" (regexp-quote saved-search-query)) + (concat "[ " saved-search-name " ]") + query))) + (notmuch-search-format-buffer-name query saved-search-type t))) + (t (notmuch-search-format-buffer-name query type nil))))) + +(defun notmuch-read-query (prompt) + "Read a notmuch-query from the minibuffer with completion. + +PROMPT is the string to prompt with." + (let* ((all-tags + (mapcar (lambda (tag) (notmuch-escape-boolean-term tag)) + (notmuch--process-lines notmuch-command "search" "--output=tags" "*"))) + (completions + (append (list "folder:" "path:" "thread:" "id:" "date:" "from:" "to:" + "subject:" "attachment:") + (mapcar (lambda (tag) (concat "tag:" tag)) all-tags) + (mapcar (lambda (tag) (concat "is:" tag)) all-tags) + (mapcar (lambda (mimetype) (concat "mimetype:" mimetype)) + (mailcap-mime-types)))) + (keymap (copy-keymap minibuffer-local-map)) + (current-query (cl-case major-mode + (notmuch-search-mode (notmuch-search-get-query)) + (notmuch-show-mode (notmuch-show-get-query)) + (notmuch-tree-mode (notmuch-tree-get-query)))) + (minibuffer-completion-table + (completion-table-dynamic + (lambda (string) + ;; Generate a list of possible completions for the current input. + (cond + ;; This ugly regexp is used to get the last word of the input + ;; possibly preceded by a '('. + ((string-match "\\(^\\|.* (?\\)\\([^ ]*\\)$" string) + (mapcar (lambda (compl) + (concat (match-string-no-properties 1 string) compl)) + (all-completions (match-string-no-properties 2 string) + completions))) + (t (list string))))))) + ;; This was simpler than convincing completing-read to accept spaces: + (define-key keymap (kbd "TAB") 'minibuffer-complete) + (let ((history-delete-duplicates t)) + (read-from-minibuffer prompt nil keymap nil + 'notmuch-search-history current-query nil)))) + +(defun notmuch-search-get-query () + "Return the current query in this search buffer." + notmuch-search-query-string) + +(put 'notmuch-search 'notmuch-doc "Search for messages.") +;;;###autoload +(defun notmuch-search (&optional query oldest-first hide-excluded target-thread + target-line no-display) + "Display threads matching QUERY in a notmuch-search buffer. + +If QUERY is nil, it is read interactively from the minibuffer. +Other optional parameters are used as follows: + + OLDEST-FIRST: A Boolean controlling the sort order of returned threads + HIDE-EXCLUDED: A boolean controlling whether to omit threads with excluded + tags. + TARGET-THREAD: A thread ID (without the thread: prefix) that will be made + current if it appears in the search results. + TARGET-LINE: The line number to move to if the target thread does not + appear in the search results. + NO-DISPLAY: Do not try to foreground the search results buffer. If it is + already foregrounded i.e. displayed in a window, this has no + effect, meaning the buffer will remain visible. + +When called interactively, this will prompt for a query and use +the configured default sort order." + (interactive + (list + ;; Prompt for a query + nil + ;; Use the default search order and exclude value (if we're doing a + ;; search from a search buffer, ignore any buffer-local overrides) + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) + + (let* ((query (or query (notmuch-read-query "Notmuch search: "))) + (buffer (get-buffer-create (notmuch-search-buffer-title query)))) + (if no-display + (set-buffer buffer) + (pop-to-buffer-same-window buffer)) + (notmuch-search-mode) + ;; Don't track undo information for this buffer + (setq buffer-undo-list t) + (setq notmuch-search-query-string query) + (setq notmuch-search-oldest-first oldest-first) + (setq notmuch-search-target-thread target-thread) + (setq notmuch-search-target-line target-line) + (setq notmuch-search-hide-excluded hide-excluded) + (notmuch-tag-clear-cache) + (when (get-buffer-process buffer) + (error "notmuch search process already running for query `%s'" query)) + (let ((inhibit-read-only t)) + (erase-buffer) + (goto-char (point-min)) + (save-excursion + (let ((proc (notmuch-start-notmuch + "notmuch-search" buffer #'notmuch-search-process-sentinel + "search" "--format=sexp" "--format-version=5" + (if oldest-first + "--sort=oldest-first" + "--sort=newest-first") + (if hide-excluded + "--exclude=true" + "--exclude=false") + query))) + ;; Use a scratch buffer to accumulate partial output. + ;; This buffer will be killed by the sentinel, which + ;; should be called no matter how the process dies. + (process-put proc 'parse-buf + (generate-new-buffer " *notmuch search parse*")) + (set-process-filter proc 'notmuch-search-process-filter) + (set-process-query-on-exit-flag proc nil)))))) + +(defun notmuch-search-refresh-view () + "Refresh the current view. + +Erases the current buffer and runs a new search with the same +query string as the current search. If the current thread is in +the new search results, then point will be placed on the same +thread. Otherwise, point will be moved to attempt to be in the +same relative position within the new buffer." + (interactive) + (notmuch-search notmuch-search-query-string + notmuch-search-oldest-first + notmuch-search-hide-excluded + (notmuch-search-find-thread-id 'bare) + (line-number-at-pos) + t) + (goto-char (point-min))) + +(defun notmuch-search-toggle-hide-excluded () + "Toggle whether to hide excluded messages. + +This command toggles whether to hide excluded messages for the current +search. The default value for this is defined by `notmuch-search-hide-excluded'." + (interactive) + (setq notmuch-search-hide-excluded (not notmuch-search-hide-excluded)) + (notmuch-search-refresh-view)) + +(defun notmuch-search-toggle-order () + "Toggle the current search order. + +This command toggles the sort order for the current search. The +default sort order is defined by `notmuch-search-oldest-first'." + (interactive) + (setq notmuch-search-oldest-first (not notmuch-search-oldest-first)) + (notmuch-search-refresh-view)) + +(defun notmuch-group-disjunctive-query-string (query-string) + "Group query if it contains a complex expression. +Enclose QUERY-STRING in parentheses if contains \"OR\" operators." + (if (string-match-p "\\<[oO][rR]\\>" query-string) + (concat "( " query-string " )") + query-string)) + +(defun notmuch-search-filter (query) + "Filter or LIMIT the current search results based on an additional query string. + +Runs a new search matching only messages that match both the +current search results AND the additional query string provided." + (interactive (list (notmuch-read-query "Filter search: "))) + (let ((grouped-query (notmuch-group-disjunctive-query-string query)) + (grouped-original-query (notmuch-group-disjunctive-query-string + notmuch-search-query-string))) + (notmuch-search (if (string= grouped-original-query "*") + grouped-query + (concat grouped-original-query " and " grouped-query)) + notmuch-search-oldest-first + notmuch-search-hide-excluded))) + +(defun notmuch-search-filter-by-tag (tag) + "Filter the current search results based on a single TAG. + +Run a new search matching only messages that match the current +search results and that are also tagged with the given TAG." + (interactive + (list (notmuch-select-tag-with-completion "Filter by tag: " + notmuch-search-query-string))) + (notmuch-search (concat notmuch-search-query-string " and tag:" tag) + notmuch-search-oldest-first + notmuch-search-hide-excluded)) + +(defun notmuch-search-by-tag (tag) + "Display threads matching TAG in a notmuch-search buffer." + (interactive + (list (notmuch-select-tag-with-completion "Notmuch search tag: "))) + (notmuch-search (concat "tag:" tag) + (default-value 'notmuch-search-oldest-first) + (default-value 'notmuch-search-hide-excluded))) + +(defun notmuch-search-edit-search (query) + "Edit the current search" + (interactive (list (read-from-minibuffer "Edit search: " + notmuch-search-query-string))) + (notmuch-search query notmuch-search-oldest-first)) + +;;;###autoload +(defun notmuch () + "Run notmuch and display saved searches, known tags, etc." + (interactive) + (notmuch-hello)) + +(defun notmuch-interesting-buffer (b) + "Whether the current buffer's major-mode is a notmuch mode." + (with-current-buffer b + (memq major-mode '(notmuch-show-mode + notmuch-search-mode + notmuch-tree-mode + notmuch-hello-mode + notmuch-message-mode)))) + +;;;###autoload +(defun notmuch-cycle-notmuch-buffers () + "Cycle through any existing notmuch buffers (search, show or hello). + +If the current buffer is the only notmuch buffer, bury it. +If no notmuch buffers exist, run `notmuch'." + (interactive) + (let (start first) + ;; If the current buffer is a notmuch buffer, remember it and then + ;; bury it. + (when (notmuch-interesting-buffer (current-buffer)) + (setq start (current-buffer)) + (bury-buffer)) + + ;; Find the first notmuch buffer. + (setq first (cl-loop for buffer in (buffer-list) + if (notmuch-interesting-buffer buffer) + return buffer)) + + (if first + ;; If the first one we found is any other than the starting + ;; buffer, switch to it. + (unless (eq first start) + (pop-to-buffer-same-window first)) + (notmuch)))) + +;;; Integrations +;;;; Hl-line Support + +(defun notmuch-hl-line-mode () + (prog1 (hl-line-mode) + (when hl-line-overlay + (overlay-put hl-line-overlay 'priority 1)))) + +;;;; Imenu Support + +(defun notmuch-search-imenu-prev-index-position-function () + "Move point to previous message in notmuch-search buffer. +Used as`imenu-prev-index-position-function' in notmuch buffers." + (notmuch-search-previous-thread)) + +(defun notmuch-search-imenu-extract-index-name-function () + "Return imenu name for line at point. +Used as `imenu-extract-index-name-function' in notmuch buffers. +Point should be at the beginning of the line." + (format "%s (%s)" + (notmuch-search-find-subject) + (notmuch-search-find-authors))) + +;;; _ + +(provide 'notmuch) + +;; After provide to avoid loops if notmuch was require'd via notmuch-init-file. +(when init-file-user ; don't load init file if the -q option was used. + (load notmuch-init-file t t nil t)) + +;;; notmuch.el ends here blob - /dev/null blob + 5b8a9d01311b4d3055bec7af4d6f45832d661f51 (mode 644) --- /dev/null +++ elpa/notmuch-0.39/rstdoc.el @@ -0,0 +1,90 @@ +;;; rstdoc.el --- help generate documentation from docstrings -*- lexical-binding: t -*- + +;; Copyright (C) 2018 David Bremner + +;; Author: David Bremner +;; Created: 26 May 2018 +;; Keywords: emacs lisp, documentation +;; Homepage: https://notmuchmail.org + +;; This file is not part of GNU Emacs. + +;; rstdoc.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 3 of the License, or +;; (at your option) any later version. +;; +;; rstdoc.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 rstdoc.el. If not, see . +;; + +;;; Commentary: + +;; Rstdoc provides a facility to extract all of the docstrings defined in +;; an elisp source file. Usage: +;; +;; emacs -Q --batch -L . -l rstdoc -f rstdoc-batch-extract foo.el foo.rsti + +;;; Code: + +(defun rstdoc-batch-extract () + "Extract docstrings to and from the files on the command line." + (apply #'rstdoc-extract command-line-args-left)) + +(defun rstdoc-extract (in-file out-file) + "Write docstrings from IN-FILE to OUT-FILE." + (load-file in-file) + (let* ((definitions (cdr (assoc (expand-file-name in-file) load-history))) + (text-quoting-style 'grave) + (doc-hash (make-hash-table :test 'eq))) + (mapc + (lambda (elt) + (let ((pair + (pcase elt + (`(defun . ,name) (cons name (documentation name))) + (`(,_ . ,_) nil) + (sym (cons sym (get sym 'variable-documentation)))))) + (when (and pair (cdr pair)) + (puthash (car pair) (cdr pair) doc-hash)))) + definitions) + (with-temp-buffer + (maphash + (lambda (key val) + (rstdoc--insert-docstring key val)) + doc-hash) + (write-region (point-min) (point-max) out-file)))) + +(defun rstdoc--insert-docstring (symbol docstring) + (insert (format "\n.. |docstring::%s| replace::\n" symbol)) + (insert (replace-regexp-in-string "^" " " + (rstdoc--rst-quote-string docstring))) + (insert "\n")) + +(defvar rst--escape-alist + '( ("\\\\='" . "\001") + ("`\\([^\n`']*\\)[`']" . "\002\\1\002") ;; good enough for now... + ("`" . "\\\\`") + ("\001" . "'") + ("\002" . "`") + ("[*]" . "\\\\*") + ("^[[:space:]]*$" . "|br|") + ("^[[:space:]]" . "|indent| ")) + "list of (regex . replacement) pairs") + +(defun rstdoc--rst-quote-string (str) + (with-temp-buffer + (insert str) + (dolist (pair rst--escape-alist) + (goto-char (point-min)) + (while (re-search-forward (car pair) nil t) + (replace-match (cdr pair)))) + (buffer-substring (point-min) (point-max)))) + +(provide 'rstdoc) + +;;; rstdoc.el ends here blob - /dev/null blob + 79004c8a751a32c9978200b1d6eca5bc40fe6cb5 (mode 644) --- /dev/null +++ elpa/paredit-26/.github/workflows/ubuntu-latest.yml @@ -0,0 +1,28 @@ +name: paredit test + +on: + push: + paths-ignore: + - .gitignore + - COPYING + - CREDITS + - NEWS + pull_request: + paths-ignore: + - .gitignore + - COPYING + - CREDITS + - NEWS + +jobs: + check: + runs-on: ubuntu-latest + steps: + - name: checkout + uses: actions/checkout@v3 + - name: install emacs + run: > + sudo apt-get update && + sudo apt-get install emacs + - name: check.sh + run: ./check.sh blob - /dev/null blob + d0689a3c9ddad4f465b4f7eb5bbbfdfe6289ae68 (mode 644) --- /dev/null +++ elpa/paredit-26/CREDITS @@ -0,0 +1,47 @@ +Paredit was inspired by: + +- Interlisp-D's structure editor SEdit +- Guillaume Germain's sedit.el for GNU Emacs + +The following people contributed to paredit by submitting patches, +discussing design, testing and finding broken corner cases, and in +other ways: + +Rudolf Adamkovič +Marco Baringer +Eli Barzilay +Edwin O'Connor +John Cowan +Iain Dalton +Peter Danenberg +Elly Jones +Daniel Gackle +Guillaume Germain +Tobias Gerdin +Phil Hagelberg +Michael Heerdegen +Thomas Hermann +David Hilton +Trey Jackson +`Joe' +Richard M Kreuter +Leo Liu +Brian Mastenbrook +`megane' +Javier Olaechea +Mark Oteiza +Eitan Postavsky +Alex Plotnick +Tobias C. Rittweiler +Andreas Roehler +Jorgen Schäfer +Vladimir Sedach +Michael Weber +Goran Weinholt +Norman Werner +Sean Whitton +John Wiegley + +(With apologies to the early contributors from before I started writing +this file whose names I may have forgotten! If your name is missing, +or if you would like your name removed, just let me know.) blob - /dev/null blob + 59659bb75fb262702a645dcef69d981d14a6a64b (mode 644) --- /dev/null +++ elpa/paredit-26/NEWS @@ -0,0 +1,816 @@ +* Paredit Release Notes -*- outline -*- + +paredit -- parenthetical editing in Emacs + +https://paredit.org + +Latest release: https://paredit.org/paredit.el +Current development version: https://paredit.org/paredit-beta.el + +** Version 26 -- 2022-11-26 + +Minor bug fix release, mainly to set a new branch scheme: + +- `master' branch is where development and releases happen + => on release, one commit to remove beta and a second to bump version +- `release' branch points at latest release commit on master +- no `maint-N' branches + +This replaces the old scheme where master was branched into maint-N and +then the beta tag was stripped off in the maint-N branch, which meant +no one branch would automatically track the current release as ELPA +prefers. + +Other changes: + +*** M-s (paredit-splice-sexp) now restores column in text fields like ielm. +*** Deletion now respects `delete-active-region'. + +** Version 25 -- 2022-11-25 + +*** paredit now lives at paredit.org. +*** M-r (paredit-raise-sexp) now respects active mark in Transient Mark Mode. +*** Paredit Mode and Electric Indent Mode are noted as incompatible. +*** M-q (paredit-reindent-defun) now respects `fill-paragraph-function'. +*** New variables `paredit-comment-prefix-...' for `paredit-comment-dwim'. +*** Reading character in Backslash escape now inherits input method. +*** M-r (paredit-raise-sexp) no longer reindents single-line sexps. +*** Various bug fixes and additions to test suite. +*** Worked around brokenness induced by Electric Indent Mode. +**** (Thanks to Sean Whitton for reporting the bug and discussing the fix.) + +NOTE: The Electric Indent Mode workaround turns out to break ielm and +other interactive modes, because paredit now defines RET, overriding +the binding in interactive modes that submits an input. + +Workaround to restore the old behaviour: + + (define-key paredit-mode-map (kbd "RET") nil) + (define-key paredit-mode-map (kbd "C-j") 'paredit-newline) + +Recommended to disable Electric Indent Mode at the same time. + +** Version 24 -- 2014-12-06 + +*** Slurp/barf now support prefix arguments with the obvious semantics. +*** HTML quick reference is a little prettier now, perhaps. +*** paredit.el no longer defines `backward-down-list'. +*** Slurp `(|) foo' now yields `(|foo)', not the frustrating `(| foo)'. +*** C-M-f/C-M-b (paredit-forward/paredit-backward) now move out of strings. +*** Changed M-" (paredit-meta-doublequote) to not break line, like M-). +*** New command: paredit-meta-doublequote-and-newline has old behaviour. +*** Several commands preserve indentation and point column better. +*** Motion commands support shift selection in GNU Emacs 24 and later. +*** `backward-delete-char' changes in GNU Emacs 24 no longer botch paredit. +*** Various bug fixes. + +** Version 23 -- 2013-04-07 + +Paredit no longer runs in GNU Emacs 20. It now requires 21 or later. + +Paredit now has a small set of automatic tests. + +*** New key: `M-?' is bound to `paredit-convolute-sexp' +*** New variable: paredit-override-check-parens-function +*** New command: paredit-delete-region +*** New command: paredit-kill-region +*** Renamed command: paredit-recentre-on-sexp -> paredit-recenter-on-sexp +*** Various bug fixes. + +** Version 22 -- 2010-10-09 + +The copying terms of paredit are now the GPLv3+, rather than the +3-clause BSD licence. + +*** Style and Bugs + +- paredit.el now has a header and footer conforming to the elisp + guidelines, so that it can be used with package.el. + +- `paredit-mode' now has an autoload cookie. + +- Miscellaneous bugs have been fixed, mostly to make paredit behave the + way it should when before it would simply signal an error, or to make + paredit signal an error when before it would do something bogus. + +*** Altered Behaviour + +- `paredit-raise-sexp' (M-r) now works when inside strings and + characters. + +- `paredit-comment-dwim' (M-;) behaves slightly differently in the + following case: + + (foo bar + |baz + quux) + + Before: + (foo bar + baz ;| + quux) + + After: + (foo bar + ;; | + baz + quux) + +- `paredit-raise-sexp', `paredit-splice-sexps', and + `paredit-comment-dwim' reindent a little more selectively. + +- `paredit-newline' tries to keep invalid structure inside comments. + +- `paredit-kill' now works in any string-like object, not just those + with double-quotes. E.g., Common Lisp's |...| notation for symbols. + +- After `...)', inserting a double-quote will insert a space too. See + also `paredit-space-for-delimiter-predicates', below. + +*** New Commands + +- `paredit-copy-as-kill' is to `paredit-kill' as `copy-region-as-kill' + is to `kill-region'. That is, `paredit-copy-as-kill' copies the + region that would be killed with `paredit-kill', but does not kill + the region. + +- `paredit-semicolon' is back, with better behaviour. + +- `paredit-{for,back}ward-{up,down}' move up and down the list + structure, like `{backward-,}{up,down}-list', but also enter and exit + strings when appropriate. C-M-u, C-M-d, C-M-p, and C-M-u are now + bound to these commands. + +- `paredit-kill-ring-save' and `paredit-kill-region' are an experiment + for killing regions without destroying structure -- specifically. + Later, I hope to implement `paredit-yank', although it is much + trickier to implement. + +*** New Variables + +- `paredit-space-for-delimiter-predicates' is a list controlling when + inserting a delimiter causes insertion of a space too. See the + documentation string for details. Example use, to make paredit less + frustrating with Common Lisp's #P, #A, #-, and #+ notations: + +(defvar common-lisp-octothorpe-quotation-characters '(?P)) +(defvar common-lisp-octothorpe-parameter-parenthesis-characters '(?A)) +(defvar common-lisp-octothorpe-parenthesis-characters '(?+ ?- ?C)) + +(defun paredit-space-for-delimiter-predicate-common-lisp (endp delimiter) + (or endp + (let ((case-fold-search t) + (look + (lambda (prefix characters n) + (looking-back + (concat prefix (regexp-opt (mapcar 'string characters))) + (min n (point)))))) + (let ((oq common-lisp-octothorpe-quotation-characters) + (op common-lisp-octothorpe-parenthesis-characters) + (opp common-lisp-octothorpe-parameter-parenthesis-characters)) + (cond ((eq (char-syntax delimiter) ?\() + (and (not (funcall look "#" op 2)) + (not (funcall look "#[0-9]*" opp 20)))) + ((eq (char-syntax delimiter) ?\") + (not (funcall look "#" oq 2))) + (else t)))))) + +(add-hook 'common-lisp-mode-hook + (defun common-lisp-mode-hook-paredit () + (make-local-variable 'paredit-space-for-delimiter-predicates) + (add-to-list 'paredit-space-for-delimiter-predicates + 'paredit-space-for-delimiter-predicate-common-lisp))) + +** Version 21 -- 2008-07-24 + +Paredit 21 no longer has a message releasing it into the public domain. +Instead it is copyright (C) 2008, Taylor R. Campbell, and available +under the terms of the 3-clause BSD licence. See the paredit.el file +for details. + +*** Style and Bugs + +- Use of the terms `parenthesis', `bracket', and `delimiter' has been + clarified throughout the file: + + . /Parentheses/ are nestable objects indicated by matching delimiter + pairs. For example, the text `(foo (bar baz) quux)' has two + parentheses, `(foo ... quux)' and `(bar baz)'; each is delimited + by matching round delimiters. + + . /Delimiters/ are the actual atomic objects that delimit + parentheses. They may be shaped differently; for example, `[' is + an opening square delimiter, and `{' is an opening curly + delimiter. + + . The terms `bracket', `brace', and `brocket' (the latter a + misspelling of `broket', for `broken bracket') are eschewed. + + The names `paredit-open-parenthesis' &c. have been changed to + `paredit-open-round' &c., and likewise with `bracket' -> `square', + `brace' -> `curly', and `brocket' -> `angled'. The old names with + the morphemes `parenthesis' and `bracket' have been preserved so that + users need not update initialization files immediately, but will + instead be confused when a subsequent minor update breaks all their + initialization files for no good reason. + +- Some commands now check their context more strictly, so that they + won't try to do anything in comments or strings. Whether this is the + right thing, I don't know. + +- Several small elements of style were adjusted. This should make no + functional difference on the code. (If it does, then I have made a + mistake.) + +- paredit.el no longer defines `kill-region-new'; the function is + instead called `paredit-hack-kill-region', to reflect its hackish + nature and to avoid name clashes. I believe that the only name + remaining defined by paredit.el without `paredit-' prefixed is + `backward-down-list', whose definition is so obvious that it would be + silly to define it any other way, so that any name conflict does not + worry me. (I suppose `kill-region-new' is obvious, too -- it is to + `kill-region' as `kill-new' is to `kill'. But the omission from a + pattern isn't as clear as with `backward-down-list'.) + +- `paredit-comment-dwim' should work in GNU Emacs 21 now, whose + newcomment.el defines no `comment-or-uncomment-region'. More and + more ugly compatibility hacks are accruing in paredit.el as a + consequence, to my dismay. Oh well. + +- The release notes are now formatted more legibly, paginated nicely, + and organized with Outline Mode. The gross discrepancy in writing + style over the years has not changed. + +- The introductory comments in the file are more clearly written now. + +- Fixed a bug in S-expression slurpage with mixed delimiters. + +*** Altered Behaviour + +- The bindings for `)' and `M-)' have been exchanged: `)' is bound to + `paredit-close-round' and `M-)' to `paredit-close-round-and-newline', + so that you can now without any glaring exceptions type new code + using the same keystrokes with and without Paredit Mode. You can + also now paste into Emacs through a terminal without leaving spurious + blank lines in the buffer. You are, of course, free to revert to the + old behaviour in your .emacs file. + +- `paredit-semicolon' is no more. Now you may insert semicolons as + you please without the infuriating escape of the following text on + the line. + +- `paredit-move-past-close-and-newline' will now leave comments on the + same line only if they are margin comments and no S-expressions are + intervening between the point and the comment; that is, only if it + looks like the margin comment really pertains to the expression being + closed will paredit leave it on the same line. + +- `paredit-backward-delete', `paredit-forward-delete', and + `paredit-kill' formerly accepted prefix arguments to run the basic + `backward-delete-char', `delete-char', and `kill-line' commands + instead, without regard for the value of the prefix argument. Now + `C-u' will run the basic commands, but + + . `paredit-kill' will pass a numeric argument on to `kill-line', and + + . `paredit-backward-delete' and `paredit-forward-delete' will both + delete N characters if given a numeric prefix argument N. + + (`paredit-kill' should probably do the same, but repeating the + command N times is probably not what you want -- what you probably + want is to kill at most N *lines*, but `paredit-kill' N times might + kill many more lines than that. I don't know what the right thing is + here, but I welcome feedback from users who want to do something like + this.) + +- With a `C-u' prefix argument, `paredit-wrap-sexp' now wraps all + S-expressions following the point until the end of the buffer or a + closing delimiter. + +- `paredit-splice-sexp' with a `C-u' prefix argument (also known as + `paredit-splice-sexp-killing-backward') will now kill from the point, + rather than from the beginning of the next S-expression (or, with + `C-u C-u', from the end of the previous S-expression). This means + that it is more likely to do what you mean with + + (let ((a b) (c d)) + |;; I want to preserve this comment after `C-u M-s'. + (foo bar baz)) + +- `paredit-splice-sexp' now splices strings, by removing backslash + escapes, or signals an error if doing so would destroy the structure + of the buffer. + +- I have finally introduced the first bit of code to try to deal + sensibly with broken buffers. It will probably go only downhill from + here, and continue in an interminable series of kludges to handle + every possible way in which the buffer can go *wrong* (it's bad + enough how many ways it can be *right*). If you try type a closing + delimiter from within a partial S-expression that has an opening + delimiter but no closing delimiter, then it will honk at you and + insert the closing delimiter -- or if what you typed doesn't match + the opening delimiter, it will just honk and refuse to do anything. + Also, `DEL' and `C-d' will delete spurious (but not [yet] mismatched) + opening and closing delimiters, respectively. (Thanks to John + Wiegley for inspiring me to do these dreary deeds.) + +*** New Commands + +- New command `paredit-yank-pop' cooperates with `paredit-wrap-sexp' by + behaving either like `yank' or like `yank-pop' if the previous + command was `paredit-wrap-sexp' or `paredit-yank-pop', and with the + added bonus of reindenting the newly wrapped form. It is in need of + a key to be bound to it; since it is different from both `yank' and + `yank-pop', I decided not to override `C-y' or `M-y', and I + considered `C-c C-y', but I imagine that many major modes want to + take that. + +- New command `paredit-focus-on-defun' moves display to the top of the + definition at the point. + +- New command `paredit-reindent-defun', which `M-q' is bound to in + Paredit Mode, indents the definition the point is on, or, if the + point is in a string or comment, fills the paragraph instead. + (Thanks to John Wiegley for the idea.) + +- New variations on slurpage, barfage, and joinage. I'm still looking + for keys to bind to these commands. Find them with the strings + `add-to-{previous,next}-list' and `join-with-{previous,next}-list' in + their names. (Again, thanks to John Wiegley for the idea.) + +- New command `paredit-convolute-sexp' performs the combined function + of `paredit-splice-sexp-killing-backward', `paredit-wrap-sexp', and + `yank'. Example: + + (let ((foo bar)) + (let ((baz quux)) + |(zot mumble) + (frotz)) + (gargle mumph)) + -> + (let ((baz quux)) + (let ((foo bar)) + (zot mumble) + (frotz) + (gargle mumph))) + + This would otherwise have been done with the key sequence `C-u M-s + C-M-u M-( C-y C-M-u C-M-q'. `C-u M-s' could be `M-up', and `C-y + C-M-u C-M-q' could be `C-c C-y' if that key is chosen for + `paredit-yank-pop', making the sequence `M-up C-M-u M-( C-c C-y'. If + there is a good key for `paredit-convolute-sexp', it could be a nice + improvement over even that terser sequence. (Once again, this was + inspired by John Wiegley's idea (and name).) + + [Observe, though, that the form (FROTZ) stuck with (ZOT MUMBLE) the + whole time, and was not carried along as the `end' of the (LET ((BAZ + QUUX)) ...) form. Hence this is *not* the idea mentioned below by + the name `paredit-interchange-sexps', but a simpler approximation of + the idea.] + +- `define-paredit-pair' now defines commands `paredit-wrap-...' for + wrapping S-expressions with different delimiters, like + `paredit-wrap-sexp'. The function `paredit-wrap-sexp' now accepts + optional arguments for the delimiters to insert; the new commands are + defined in terms of the modified `paredit-wrap-sexp'. `M-[' is now + bound to `paredit-wrap-square'. + +** Version 20 -- 2007-04-04 + +*** Preliminary Support for XEmacs + +This version introduces preliminary support for XEmacs. The changes +needed were: + +- `check-parens' is called by the `paredit-mode' initialization only if + it is fbound. + +- The forward and backward deletion keys are specified differently in + GNU Emacs and XEmacs. + +- `paredit-forward' and `paredit-backward' use a "_" interactive + specification in XEmacs in order to preserve the mark. + +- `paredit-region-active-p' is just `region-active-p' in XEmacs. + +- Some hair was needed to handle S-expression parse error conditions + properly, and versions of XEmacs earlier than 21.5 may have obscure + problems as a result. + +*** Style and Bugs + +- rxvt-specific terminal escape sequences are no longer bound to the + commands that the keys those sequences denote are. Set your + environment variables correctly and keep your rxvt.el updated. + (Aren't terminals fun?) + +- HTML output is now properly quoted. Some vestigial indirections in + the tables have been removed. + +- Yet *ANOTHER* `paredit-kill' bug is fixed. I do not know what the + bug is or why it happened, but it seems to be gone now. + +- Improved robustness of `paredit-join-sexps' and `paredit-splice-sexp' + with respect to their use in the middle of atoms, and made splicing + within a string illegal. + +- Fixed several bugs in the paredit word killing commands. In the + process, however, I encountered what seems to be a bug in Emacs's + `parse-partial-sexp', which may mean bugs in other things... + +- Eliminated dependency on `cl' feature. + +- Fixed a bug in `paredit-backward-kill-word' that would cause deletion + of the first double-quote in `(foo "|")'. + +- Fixed a bug with `paredit-backward-kill-word' at the end of buffer. + +- Fixed a bug with `paredit-backward-kill-word' before any words in a + buffer. + +*** Altered Behaviour and New Functionality + +- `paredit-mode' now accepts a prefix argument to mean that it should + not check the parentheses in the buffer first. Supply the prefix + argument with care; though it is useful for editing small parts of a + buffer in Lisp when the rest is random, it might also screw the whole + buffer up in unpredictable ways, because most of paredit doesn't + even try to handle invalid structure. + +- Parenthesis blinking is improved somewhat to better respect user + customization of `blink-matching-paren'. + +- The paredit minor mode no longer exchanges C-j & RET; following the + GNU Emacs conventions, it now leaves RET alone and binds C-j to + `paredit-newline'. Those of you, such as me, who relied on the old + exchange will have to update your .emacs files. + +- C-left and C-right are now bound to paredit-forward-barf-sexp and + paredit-forward-slurp-sexp, instead of M-left and M-right, whose word + motion bindings are no longer shadowed. + +- The behaviour of (, ", M-(, and M-" with respect to active regions + and prefix arguments has been regularized: + + . With neither an active region, i.e. an active mark and + transient-mark-mode, ( and " will insert a pair of delimiters at + the point, and M-( and M-" will wrap the following expression with + delimiters. + + . With an active region and no prefix argument, if and only if the + region contains only balanced expressions, all four commands will + wrap the region with the respective delimiters. + + . With a prefix argument N, all four commands will wrap the next N + expressions with the commands' respective delimiters. + + " and M-", of course, escape any characters that need escaping first + if they are used to wrap regions. + +- Implemented slurpage into strings. + +- Made `M-- M-s' equivalent to `M-- M-1 M-s'. + +- Changed `paredit-insert-pair' so that it will not skip whitespace + before inserting the pair. + +- `paredit-splice-sexp' with a prefix argument and friends (i.e. `M-s', + `M-', and `M-') now always create a new entry on the kill + ring. + +** Version 19 -- 2006-03-28 + +This version introduces support for delimiters other than round +brackets. Previously, if the major mode's syntax table considered +square brackets (and curly braces, &c.) to be delimiters, since no +paredit commands would insert them balanced, deleting them would be +tricky: paredit's DEL & C-d bindings would refuse to delete them +because they would be imbalanced unless you manually type the closing +delimiter. + +Now commands are defined for the opening and closing of parentheses +(round), brackets (square), braces (curly), and brockets (angled), +named `paredit-open-', `paredit-close--and-newline', and +`paredit-close-'; paredit-mode binds the opening and closing +square bracket keys to be `paredit-open-bracket' and `paredit-close- +bracket', respectively. The rest you can bind yourself; this minimal +pair of bindings will, I think, account for accidental insertion, +elisp vectors, and (bletch) the equation of square and round brackets +as parentheses in some non-standard Scheme extensions. + +Also now supported in this version is insertion of delimiter pairs +around active regions in transient-mark-mode. If you mark a region +with transient-mark-mode enabled, you can use any of the delimiter +pair insertion keys (like opening round bracket, double-quote, &c.) +to insert a pair of delimiters around the region. There are now two +ways to parenthesize lists of expressions with visual feedback: using +M-( (paredit-wrap-sexp) followed by C-) (paredit-forward-slurp-sexp) +until satisfied, and now C-M-SPC (mark-sexp) until you have marked +the desired expressions and then any of the delimiter pair insertion +keys to insert the delimiters. + +** Version 18 -- 2006-02-11 + +*** Style and Bugs + +- Corrected terminal arrow key sequences *again*. M-left and M-right + were backwards. + +- Put the save-excursion back in paredit-recentre-on-sexp. I don't + remember why it was taken out in version 13. + +- Fixed HTML output to stop producing spurious tags. + +- Corrected a number of paredit command examples. + +- Aesthetic changes to the code: + + . Regularized some aspects of code style. + + . Repaginated so that all pages are at most 80 lines long, and most + are at least 40 lines. + + . Formatted headings for an outline regexp to match so that + outline-minor-mode works nicely on paredit.el. + +*** Altered Behaviour and New Functionality + +- Implemented paredit-forward-kill-word & paredit-backward-kill-word, + or M-d & M-DEL, which are like kill-word & backward-kill-word, but + they will not kill parenthesis, string, or comment delimiters; they + will preserve the structure of S-expressions, while the built-in + Emacs word killing commands would destroy it. + +- M-" is now bound to paredit-meta-doublequote, which has the old + behaviour of paredit-close-string-and-newline if within a string, + but which wraps the following S-expression (or N S-expressions) in + double-quotes if without a string; paredit-doublequote does the + same, but the default argument is 0, not 1. + +- M-S (paredit-split-sexp) no longer deletes horizontal space in + strings before splitting them into two. The rationale, as + suggested by Zbigniew Szadkowski, is that whitespace is usually + significant in strings, while not in lists, and you can type M-\ + M-S if you really do want the horizontal space deleted anyway. + +- Reintroduced paredit-join-sexps as M-J. The implementation is now + more robust: it ensures that the two S-expressions to join match -- + i.e. they are both lists, or they are both strings, or they are + both symbols --, and it correctly handles the atom case now as + well. + +- Extended paredit command examples to allow multiple steps in + succession of a single example. + +** Version 17 -- 2005-12-31 + +*** Style and Bugs + +- Rewrote all documentation strings to be in the imperative mood, per + GNU Emacs's guidelines. Some documentation strings may have been + corrected, too, but I can't be bothered to grovel through the diff + to pick out all changes to all documentation strings. + +- Forced parenthesis flashing even with show-paren-mode enabled. + +- Fixed bug in forward deletion within strings so that the empty + string can be deleted. + +- Simplified determination of whether the point is in a comment. + +*** Altered Behaviour and New Functionality + +- Eliminated paredit-terminal-mode. All key bindings it had are now + incorporated into paredit-mode's keymap. I may have changed some + keybindings, too, but I don't remember what they were if I did. I + think I fixed some of the keybindings in the terminal. + +- Added examples to documentation of all paredit commands, as well as + code to generate an HTML file containing the examples in nicely + formatted tables (sorry, web purists). + +- Made paredit-mode refuse to be enabled in a buffer with imbalanced + parentheses. + +- Updated documentary heading. It now explains how to customize keys + while still autoloading and how to make paredit's RET work nicely + with SLIME's REPL. + +- Improved semicolon insertion: (a) to accept a numeric prefix + argument dictating a number of semicolons to insert, instead of a + prefix argument that forces the insertion of a semicolon without a + trailing newline, which can be effected with C-q anyway; and (b) to + allow insertion of semicolons before existing comments without + inserting a superfluous leading newline. To comment out code, you + must still use M-; or M-x comment-region. + +** Version 16 -- 2005 + +- Introduced M-S (paredit-split-sexp) to split lists or strings from + the middle. + +- Fixed the definition of M-; to use (kbd "M-;") to correctly + identify the key sequence meta-semicolon, not "M-;" for M hyphen + semicolon. + +** Version 15 -- 2005 + +- Rewrote comment insertion code. + +- Implemented M-; (paredit-comment-dwim), which is like comment-dwim + but inserts comments more appropriately with respect to paredit. + +** Version 14 -- 2005 + +Version 14 introduced fancy comment handling: + +- paredit-close-list-and-newline now refuses to move a margin comment + to another line; instead it will help to preserve the column of the + comment. + +- The semicolon key is now bound to a command that will automatically + move any code following the point onto the next line, so that you + do not inadvertently comment out half expressions. You can still + use M-; (comment-dwim) to comment out specific regions that are not + meant to be code (e.g., old comments that were accidentally + uncommented) or whole S-expressions, usually in conjunction with + C-M-SPC (mark-sexp). + +** Version 13 -- 2005 + +- Removed M-\ (paredit-join-sexps), whose key binding conflicts with + delete-horizontal-space and whose implementation was inadequate and + led to general uselessness of the command. + +- Improved RET (paredit-newline) so that it does not do anything + fancy within strings and first tests whether the point is in a + comment before checking whether it is in a character. + +- Changed paredit-skip-whitespace from skip-syntax-{forward,backward} + to skip-chars-{forward,backward}, because in the Lisp syntax table + newlines are not considered whitespace -- rather, they are comment + ends --, but we want to skip them nevertheless. + +- Corrected paredit-kill in a way I don't understand. + +- Minor code improvements, including: + + . Changed call to previous-line to use forward-line instead. + . Removed unnecessary save-excursion in paredit-recentre-on-sexp. + . IF indentation changes. + +** Version 12 -- 2005 + +- Implemented M-r (paredit-raise-sexp), which raises a single + S-expression up the tree, deleting all of its siblings and its + enclosing list. + +- Rearranged some arrow key bindings again. + +- Made paredit-forward-delete and paredit-backward-delete check for + buffer bounds and also matching of the delimiters of empty lists. + +- Added a buffer bounds check to paredit-kill. + +- Made backward barfing signal an error, not just a message. + +** Version 11 -- 2005 + +- Changed the key for paredit-splice-sexp from M-/, which is by + default the popular dabbrev-expand, to M-s, which I was surprised + to find no existing binding for. + +- Added a prefix argument to paredit-splice-sexp; see the command's + documentation for details. M-up is now equivalent to C-u M-s; + M-down, to C-u C-u M-s. + +- Fixed a lot of the terminal key sequences for the arrow key + bindings in paredit-terminal-mode. + +- Modified the behaviour of paredit-forward and paredit-backward to + change only one level of nesting depth, not to repeat until there + is a sibling S-expression to move across. + +- Changed a lot of code to use character syntax, instead of exact + character comparisons, for better generality. + +- Rewrote much of paredit-kill, again. + +** Version 10 -- 2005 + +- Introduced paredit-forward and paredit-backward, which are like + forward-sexp and backward-sexp but which will also go up a nesting + level if at the end of a list. + +- Introduced C-c C-M-l (paredit-recentre-on-sexp), whose name is + self-explanatory. + +- Added support for numeric prefix arguments to paredit-open-list. + +- Fixed paredit-kill so that it would correctly kill whitespace + between parentheses, as in ( ). + +- Changed suggestion of what to put in your .emacs from require to + autoload. + +** Version 9 -- 2005 + +- Introduced enable-paredit-mode and disable-paredit-mode to better + choose which one to enable. + +- Forced blinkage of matching parentheses in paredit-close-list and + paredit-close-list-and-newline, even if show-paren-mode is enabled. + +** Version 8 -- 2005 + +- Added paredit-terminal-mode, which is like paredit-mode but which + provides key bindings that work in terminals, while paredit-mode + contains many (such as controlled brackets) that do not work in + terminals. Thanks to Jorgen Schaefer for suggesting many of the + terminal key bindings. + +- Exchanged RET and C-j: RET now inserts the fancy newline with auto- + indentation, while C-j inserts a literal line feed. While this + defies convention, and some people prefer not to do this, I have + found that it is more convenient for RET to have the behaviour of + the common case, where auto-indentation is desired, and for C-j to + insert the uncommon exact, literal line feed. You can always + customize the key bindings yourself, of course. + +- Rearranged arrow key bindings. + +- Implemented paredit-close-list-and-newline, which is like + paredit-close-list followed by RET (paredit-newline); and M-" + (paredit-close-string-and-newline), which is similar but for + strings. + The closing round bracket character now inserts the newline, while + the meta modifier inhibits this. + +- Overhauled paredit-kill. + +- Extended slurpage and barfage to permit their operation across + arbitrary depth changes. + +- Fixed bizarre bug with backward barfage. I apologize for the + alliteration. + +- Fixed a number of other small bugs. + +- Prefixed `paredit-' to the remaining functions defined in the file + that did not already have the prefix. + +- Defined backward-down-list, which for some reason is not provided + by lisp.el, although up-list, down-list, & backward-up-list all + are. (This is the sole exception to the above item. It deserves + no prefix because it ought to be defined in lisp.el with this name + anyway.) + +** Version 7 -- 2005-09 + +- Changed paredit-open-list and paredit-close-list so that they will + refuse to insert parentheses inside character literals. + +- Substituted new code for GNU Emacs's move-past-close-and-reindent. + I do not remember why now, and I no longer understand either code + well enough to discern differences, other than that Emacs's + m-p-c-a-r is probably faster because it incrementally parses each + step of the way. All I can see is that paredit.el's code now + inserts indentation before the closing parenthesis while Emacs's + m-p-c-a-r does not. + +- Fixed bugs in deletion within character literals and strings. + +** Versions 2 through 6 -- 2005-08-09 + +(I lost versions 2, 3, 4, & 5.) + +- Flushed M-" (paredit-insert-doublequote), which was rather useless + and which " (paredit-doublequote) now subsumes the functionality of. + +- Added instrumented forward deletion as well as backward deletion, + which now behave well inside strings. + +- Flushed unnecessary individual round bracket insertion keys; use + C-q instead. + +- Added C-left & C-right: backward-sexp & forward-sexp, respectively. + +- Fixed the test of whether the point is in a character literal. + +- Modified " (paredit-doublequote) to insert escaped double-quote if + in the middle of the string, rather than to jump past the string's + closing delimiter. + +- Introduced bogus backslash escaping mechanism. + +- Introduced new command for breaking the line and indenting, and + bound C-j, rather than RET, to it, according to convention. + +- Improved C-k (paredit-kill), particularly in strings where it will + no longer kill the closing delimiter of the string. + +- Changed the splicage, joinage, slurpage, and barfage commands so + that they will reindent only the modified list, not the whole + definition. + +** Version 1 -- 2005-08-01 blob - /dev/null blob + feace64a572187bb520b32fcafcfc8e72e7b1dd7 (mode 644) --- /dev/null +++ elpa/paredit-26/paredit-autoloads.el @@ -0,0 +1,55 @@ +;;; paredit-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from paredit.el + +(autoload 'paredit-mode "paredit" "\ +Minor mode for pseudo-structurally editing Lisp code. + +With a prefix argument, enable Paredit Mode even if there are + unbalanced parentheses in the buffer. +Paredit behaves badly if parentheses are unbalanced, so exercise + caution when forcing Paredit Mode to be enabled, and consider + fixing unbalanced parentheses instead. +\\ + +This is a minor mode. If called interactively, toggle the `Paredit +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `paredit-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(autoload 'enable-paredit-mode "paredit" "\ +Turn on pseudo-structural editing of Lisp code." t) +(register-definition-prefixes "paredit" '("disable-paredit-mode" "paredit-")) + +;;; End of scraped data + +(provide 'paredit-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; paredit-autoloads.el ends here blob - /dev/null blob + 37f6ee80f3febb393e8f2d049c7e43f31e0996b7 (mode 644) --- /dev/null +++ elpa/paredit-26/paredit-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from paredit.el -*- no-byte-compile: t -*- +(define-package "paredit" "26" "minor mode for editing parentheses" 'nil :commit "72cc1f6055321a53021186b86d2f825167b81478" :url "https://elpa.nongnu.org/nongnu/paredit.html" :authors '(("Taylor R. Campbell" . "campbell@paredit.org")) :maintainer '("Taylor R. Campbell" . "campbell@paredit.org") :keywords '("lisp")) blob - /dev/null blob + 55d5a6836f8a31d4ec28baf654d41a5cb2ab7e2d (mode 644) --- /dev/null +++ elpa/paredit-26/paredit.el @@ -0,0 +1,3054 @@ +;;; paredit.el --- minor mode for editing parentheses -*- Mode: Emacs-Lisp -*- + +;; Copyright (C) 2005--2022 Taylor R. Campbell + +;; Author: Taylor R. Campbell +;; Version: 26 +;; Created: 2005-07-31 +;; Keywords: lisp + +;; Paredit 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 3 of the License, or +;; (at your option) any later version. +;; +;; Paredit 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 paredit. If not, see . + +;;; Paredit - https://paredit.org +;;; +;;; Latest release: https://paredit.org/paredit.el +;;; Current development version: https://paredit.org/paredit-beta.el +;;; Release notes: https://paredit.org/NEWS + +;;; Install paredit by placing `paredit.el' in `/path/to/elisp', a +;;; directory of your choice, and adding to your .emacs file: +;;; +;;; (add-to-list 'load-path "/path/to/elisp") +;;; (autoload 'enable-paredit-mode "paredit" +;;; "Turn on pseudo-structural editing of Lisp code." +;;; t) +;;; +;;; Start Paredit Mode on the fly with `M-x enable-paredit-mode RET', +;;; or always enable it in a major mode `M' (e.g., `lisp') with: +;;; +;;; (add-hook 'M-mode-hook 'enable-paredit-mode) +;;; +;;; Customize paredit using `eval-after-load': +;;; +;;; (eval-after-load 'paredit +;;; '(progn +;;; (define-key paredit-mode-map (kbd "ESC M-A-C-s-)") +;;; 'paredit-dwim))) +;;; +;;; Send questions, bug reports, comments, feature suggestions, &c., +;;; via email to the author's surname at paredit.org. +;;; +;;; Paredit should run in GNU Emacs 21 or later and XEmacs 21.5.28 or +;;; later. + +;;; The paredit minor mode, Paredit Mode, binds common character keys, +;;; such as `(', `)', `"', and `\', to commands that carefully insert +;;; S-expression structures in the buffer: +;;; +;;; ( inserts `()', leaving the point in the middle; +;;; ) moves the point over the next closing delimiter; +;;; " inserts `""' if outside a string, or inserts an escaped +;;; double-quote if in the middle of a string, or moves over the +;;; closing double-quote if at the end of a string; and +;;; \ prompts for the character to escape, to avoid inserting lone +;;; backslashes that may break structure. +;;; +;;; In comments, these keys insert themselves. If necessary, you can +;;; insert these characters literally outside comments by pressing +;;; `C-q' before these keys, in case a mistake has broken the +;;; structure. +;;; +;;; These key bindings are designed so that when typing new code in +;;; Paredit Mode, you can generally type exactly the same sequence of +;;; keys you would have typed without Paredit Mode. +;;; +;;; Paredit Mode also binds common editing keys, such as `DEL', `C-d', +;;; and `C-k', to commands that respect S-expression structures in the +;;; buffer: +;;; +;;; DEL deletes the previous character, unless it is a delimiter: DEL +;;; will move the point backward over a closing delimiter, and +;;; will delete a delimiter pair together if between an open and +;;; closing delimiter; +;;; +;;; C-d deletes the next character in much the same manner; and +;;; +;;; C-k kills all S-expressions that begin anywhere between the point +;;; and the end of the line or the closing delimiter of the +;;; enclosing list, whichever is first. +;;; +;;; If necessary, you can delete a character, kill a line, &c., +;;; irrespective of S-expression structure, by pressing `C-u' before +;;; these keys, in case a mistake has broken the structure. +;;; +;;; Finally, Paredit Mode binds some keys to complex S-expression +;;; editing operations. For example, `C-' makes the enclosing +;;; list slurp up an S-expression to its right (here `|' denotes the +;;; point): +;;; +;;; (foo (bar | baz) quux) C- (foo (bar | baz quux)) +;;; +;;; Note: Paredit Mode is not compatible with Electric Indent Mode. +;;; Use one or the other, not both. If you want RET to auto-indent and +;;; C-j to just insert newline in Paredit Mode, simply rebind the keys +;;; with the following fragment in your .emacs file: +;;; +;;; (eval-after-load 'paredit +;;; '(progn +;;; (define-key paredit-mode-map (kbd "RET") 'paredit-newline) +;;; (define-key paredit-mode-map (kbd "C-j") nil))) +;;; +;;; Some paredit commands automatically reindent code. When they do, +;;; they try to indent as locally as possible, to avoid interfering +;;; with any indentation you might have manually written. Only the +;;; advanced S-expression manipulation commands automatically reindent, +;;; and only the forms that they immediately operated upon (and their +;;; subforms). +;;; +;;; This code is written for clarity, not efficiency. It frequently +;;; walks over S-expressions redundantly. If you have problems with +;;; the time it takes to execute some of the commands, let me know. + +;;; This assumes Unix-style LF line endings. + +(defconst paredit-version 26) +(defconst paredit-beta-p nil) + +(eval-and-compile + + (defun paredit-xemacs-p () + ;; No idea where I got this definition from. Edward O'Connor + ;; (hober in #emacs) suggested the current definition. + ;; (and (boundp 'running-xemacs) + ;; running-xemacs) + (featurep 'xemacs)) + + (defun paredit-gnu-emacs-p () + ;++ This could probably be improved. + (not (paredit-xemacs-p))) + + (defmacro xcond (&rest clauses) + "Exhaustive COND. +Signal an error if no clause matches." + `(cond ,@clauses + (t (error "XCOND lost.")))) + + (defalias 'paredit-warn (if (fboundp 'warn) 'warn 'message)) + + (defvar paredit-sexp-error-type + (with-temp-buffer + (insert "(") + (condition-case condition + (backward-sexp) + (error (if (eq (car condition) 'error) + (paredit-warn "%s%s%s%s%s" + "Paredit is unable to discriminate" + " S-expression parse errors from" + " other errors. " + " This may cause obscure problems. " + " Please upgrade Emacs.")) + (car condition))))) + + (defmacro paredit-handle-sexp-errors (body &rest handler) + `(condition-case () + ,body + (,paredit-sexp-error-type ,@handler))) + + (put 'paredit-handle-sexp-errors 'lisp-indent-function 1) + + (defmacro paredit-ignore-sexp-errors (&rest body) + `(paredit-handle-sexp-errors (progn ,@body) + nil)) + + (put 'paredit-ignore-sexp-errors 'lisp-indent-function 0) + + (defmacro paredit-preserving-column (&rest body) + "Evaluate BODY and restore point to former column, relative to code. +Assumes BODY will change only indentation. +If point was on code, it moves with the code. +If point was on indentation, it stays in indentation." + (let ((column (make-symbol "column")) + (indentation (make-symbol "indentation"))) + `(let ((,column (paredit-current-column)) + (,indentation (paredit-current-indentation))) + (let ((value (progn ,@body))) + (paredit-restore-column ,column ,indentation) + value)))) + + (put 'paredit-preserving-column 'lisp-indent-function 0) + + nil) + +;;;; Minor Mode Definition + +(defvar paredit-lighter " Paredit" + "Mode line lighter Paredit Mode.") + +(defvar paredit-mode-map (make-sparse-keymap) + "Keymap for the paredit minor mode.") + +(defvar paredit-override-check-parens-function + (lambda (condition) (declare ignore condition) nil) + "Function to tell whether unbalanced text should inhibit Paredit Mode.") + +;;;###autoload +(define-minor-mode paredit-mode + "Minor mode for pseudo-structurally editing Lisp code. +With a prefix argument, enable Paredit Mode even if there are + unbalanced parentheses in the buffer. +Paredit behaves badly if parentheses are unbalanced, so exercise + caution when forcing Paredit Mode to be enabled, and consider + fixing unbalanced parentheses instead. +\\" + :lighter paredit-lighter + ;; Setting `paredit-mode' to false here aborts enabling Paredit Mode. + (if (and paredit-mode + (not current-prefix-arg)) + (condition-case condition + (check-parens) + (error + (if (not (funcall paredit-override-check-parens-function condition)) + (progn (setq paredit-mode nil) + (signal (car condition) (cdr condition)))))))) + +(defun paredit-override-check-parens-interactively (condition) + (y-or-n-p (format "Enable Paredit Mode despite condition %S? " condition))) + +;;;###autoload +(defun enable-paredit-mode () + "Turn on pseudo-structural editing of Lisp code." + (interactive) + (paredit-mode +1)) + +(defun disable-paredit-mode () + "Turn off pseudo-structural editing of Lisp code." + (interactive) + (paredit-mode -1)) + +(defvar paredit-backward-delete-key + (xcond ((paredit-xemacs-p) "BS") + ((paredit-gnu-emacs-p) "DEL"))) + +(defvar paredit-forward-delete-keys + (xcond ((paredit-xemacs-p) '("DEL")) + ((paredit-gnu-emacs-p) '("" "")))) + +;;;; Paredit Keys + +;;; Separating the definition and initialization of this variable +;;; simplifies the development of paredit, since re-evaluating DEFVAR +;;; forms doesn't actually do anything. + +(defvar paredit-commands nil + "List of paredit commands with their keys and examples.") + +;;; Each specifier is of the form: +;;; (key[s] function (example-input example-output) ...) +;;; where key[s] is either a single string suitable for passing to KBD +;;; or a list of such strings. Entries in this list may also just be +;;; strings, in which case they are headings for the next entries. + +(progn (setq paredit-commands + `( + "Basic Insertion Commands" + ("(" paredit-open-round + ("(a b |c d)" + "(a b (|) c d)") + ("(foo \"bar |baz\" quux)" + "(foo \"bar (|baz\" quux)")) + (")" paredit-close-round + ("(a b |c )" "(a b c)|") + ("; Hello,| world!" + "; Hello,)| world!")) + ("M-)" paredit-close-round-and-newline + ("(defun f (x| ))" + "(defun f (x)\n |)") + ("; (Foo.|" + "; (Foo.)|")) + ("[" paredit-open-square + ("(a b |c d)" + "(a b [|] c d)") + ("(foo \"bar |baz\" quux)" + "(foo \"bar [|baz\" quux)")) + ("]" paredit-close-square + ("(define-key keymap [frob| ] 'frobnicate)" + "(define-key keymap [frob]| 'frobnicate)") + ("; [Bar.|" + "; [Bar.]|")) + + ("\"" paredit-doublequote + ("(frob grovel |full lexical)" + "(frob grovel \"|\" full lexical)" + "(frob grovel \"\"| full lexical)") + ("(foo \"bar |baz\" quux)" + "(foo \"bar \\\"|baz\" quux)") + ("(frob grovel) ; full |lexical" + "(frob grovel) ; full \"|lexical")) + ("M-\"" paredit-meta-doublequote + ("(foo \"bar |baz\" quux)" + "(foo \"bar baz\"| quux)") + ("(foo |(bar #\\x \"baz \\\\ quux\") zot)" + ,(concat "(foo \"|(bar #\\\\x \\\"baz \\\\" + "\\\\ quux\\\")\" zot)"))) + ("\\" paredit-backslash + ("(string #|)\n ; Character to escape: x" + "(string #\\x|)") + ("\"foo|bar\"\n ; Character to escape: \"" + "\"foo\\\"|bar\"")) + (";" paredit-semicolon + ("|(frob grovel)" + ";|(frob grovel)") + ("(frob |grovel)" + "(frob ;|grovel\n )") + ("(frob |grovel (bloit\n zargh))" + "(frob ;|grovel\n (bloit\n zargh))") + ("(frob grovel) |" + "(frob grovel) ;|")) + ("M-;" paredit-comment-dwim + ("(foo |bar) ; baz" + "(foo bar) ; |baz") + ("(frob grovel)|" + "(frob grovel) ;|") + ("(zot (foo bar)\n|\n (baz quux))" + "(zot (foo bar)\n ;; |\n (baz quux))") + ("(zot (foo bar) |(baz quux))" + "(zot (foo bar)\n ;; |\n (baz quux))") + ("|(defun hello-world ...)" + ";;; |\n(defun hello-world ...)")) + + (() paredit-newline + ("(let ((n (frobbotz))) |(display (+ n 1)\nport))" + ,(concat "(let ((n (frobbotz)))" + "\n |(display (+ n 1)" + "\n port))"))) + ("RET" paredit-RET) + ("C-j" paredit-C-j) + + "Deleting & Killing" + (,paredit-forward-delete-keys + paredit-forward-delete + ("(quu|x \"zot\")" "(quu| \"zot\")") + ("(quux |\"zot\")" + "(quux \"|zot\")" + "(quux \"|ot\")") + ("(foo (|) bar)" "(foo | bar)") + ("|(foo bar)" "(|foo bar)")) + (,paredit-backward-delete-key + paredit-backward-delete + ("(\"zot\" q|uux)" "(\"zot\" |uux)") + ("(\"zot\"| quux)" + "(\"zot|\" quux)" + "(\"zo|\" quux)") + ("(foo (|) bar)" "(foo | bar)") + ("(foo bar)|" "(foo bar|)")) + ("C-d" paredit-delete-char + ("(quu|x \"zot\")" "(quu| \"zot\")") + ("(quux |\"zot\")" + "(quux \"|zot\")" + "(quux \"|ot\")") + ("(foo (|) bar)" "(foo | bar)") + ("|(foo bar)" "(|foo bar)")) + ("C-k" paredit-kill + ("(foo bar)| ; Useless comment!" + "(foo bar)|") + ("(|foo bar) ; Useful comment!" + "(|) ; Useful comment!") + ("|(foo bar) ; Useless line!" + "|") + ("(foo \"|bar baz\"\n quux)" + "(foo \"|\"\n quux)")) + ("M-d" paredit-forward-kill-word + ("|(foo bar) ; baz" + "(| bar) ; baz" + "(|) ; baz" + "() ;|") + (";;;| Frobnicate\n(defun frobnicate ...)" + ";;;|\n(defun frobnicate ...)" + ";;;\n(| frobnicate ...)")) + (,(concat "M-" paredit-backward-delete-key) + paredit-backward-kill-word + ("(foo bar) ; baz\n(quux)|" + "(foo bar) ; baz\n(|)" + "(foo bar) ; |\n()" + "(foo |) ; \n()" + "(|) ; \n()")) + + "Movement & Navigation" + ("C-M-f" paredit-forward + ("(foo |(bar baz) quux)" + "(foo (bar baz)| quux)") + ("(foo (bar)|)" + "(foo (bar))|")) + ("C-M-b" paredit-backward + ("(foo (bar baz)| quux)" + "(foo |(bar baz) quux)") + ("(|(foo) bar)" + "|((foo) bar)")) + ("C-M-u" paredit-backward-up) + ("C-M-d" paredit-forward-down) + ("C-M-p" paredit-backward-down) ; Built-in, these are FORWARD- + ("C-M-n" paredit-forward-up) ; & BACKWARD-LIST, which have + ; no need given C-M-f & C-M-b. + + "Depth-Changing Commands" + ("M-(" paredit-wrap-round + ("(foo |bar baz)" + "(foo (|bar) baz)")) + ("M-s" paredit-splice-sexp + ("(foo (bar| baz) quux)" + "(foo bar| baz quux)")) + (("M-" "ESC ") + paredit-splice-sexp-killing-backward + ("(foo (let ((x 5)) |(sqrt n)) bar)" + "(foo |(sqrt n) bar)")) + (("M-" "ESC ") + paredit-splice-sexp-killing-forward + ("(a (b c| d e) f)" + "(a b c| f)")) + ("M-r" paredit-raise-sexp + ("(dynamic-wind in (lambda () |body) out)" + "(dynamic-wind in |body out)" + "|body")) + ("M-?" paredit-convolute-sexp + ("(let ((x 5) (y 3)) (frob |(zwonk)) (wibblethwop))" + "(frob |(let ((x 5) (y 3)) (zwonk) (wibblethwop)))")) + + "Barfage & Slurpage" + (("C-)" "C-") + paredit-forward-slurp-sexp + ("(foo (bar |baz) quux zot)" + "(foo (bar |baz quux) zot)") + ("(a b ((c| d)) e f)" + "(a b ((c| d) e) f)")) + (("C-}" "C-") + paredit-forward-barf-sexp + ("(foo (bar |baz quux) zot)" + "(foo (bar |baz) quux zot)")) + (("C-(" "C-M-" "ESC C-") + paredit-backward-slurp-sexp + ("(foo bar (baz| quux) zot)" + "(foo (bar baz| quux) zot)") + ("(a b ((c| d)) e f)" + "(a (b (c| d)) e f)")) + (("C-{" "C-M-" "ESC C-") + paredit-backward-barf-sexp + ("(foo (bar baz |quux) zot)" + "(foo bar (baz |quux) zot)")) + + "Miscellaneous Commands" + ("M-S" paredit-split-sexp + ("(hello| world)" + "(hello)| (world)") + ("\"Hello, |world!\"" + "\"Hello, \"| \"world!\"")) + ("M-J" paredit-join-sexps + ("(hello)| (world)" + "(hello| world)") + ("\"Hello, \"| \"world!\"" + "\"Hello, |world!\"") + ("hello-\n| world" + "hello-|world")) + ("C-c C-M-l" paredit-recenter-on-sexp) + ("M-q" paredit-reindent-defun) + )) + nil) ; end of PROGN + +;;;;; Command Examples + +(eval-and-compile + (defmacro paredit-do-commands (vars string-case &rest body) + (let ((spec (nth 0 vars)) + (keys (nth 1 vars)) + (fn (nth 2 vars)) + (examples (nth 3 vars))) + `(dolist (,spec paredit-commands) + (if (stringp ,spec) + ,string-case + (let ((,keys (let ((k (car ,spec))) + (cond ((stringp k) (list k)) + ((listp k) k) + (t (error "Invalid paredit command %s." + ,spec))))) + (,fn (cadr ,spec)) + (,examples (cddr ,spec))) + ,@body))))) + + (put 'paredit-do-commands 'lisp-indent-function 2)) + +(defun paredit-define-keys () + (paredit-do-commands (spec keys fn examples) + nil ; string case + (dolist (key keys) + (define-key paredit-mode-map (read-kbd-macro key) fn)))) + +(defun paredit-function-documentation (fn) + (let ((original-doc (get fn 'paredit-original-documentation)) + (doc (documentation fn 'function-documentation))) + (or original-doc + (progn (put fn 'paredit-original-documentation doc) + doc)))) + +(defun paredit-annotate-mode-with-examples () + (let ((contents + (list (paredit-function-documentation 'paredit-mode)))) + (paredit-do-commands (spec keys fn examples) + (push (concat "\n \n" spec "\n") + contents) + (let ((name (symbol-name fn))) + (if (string-match (symbol-name 'paredit-) name) + (push (concat "\n\n\\[" name "]\t" name + (if examples + (mapconcat (lambda (example) + (concat + "\n" + (mapconcat 'identity + example + "\n --->\n") + "\n")) + examples + "") + "\n (no examples)\n")) + contents)))) + (put 'paredit-mode 'function-documentation + (apply 'concat (reverse contents)))) + ;; PUT returns the huge string we just constructed, which we don't + ;; want it to return. + nil) + +(defun paredit-annotate-functions-with-examples () + (paredit-do-commands (spec keys fn examples) + nil ; string case + (put fn 'function-documentation + (concat (paredit-function-documentation fn) + "\n\n\\\\[" (symbol-name fn) "]\n" + (mapconcat (lambda (example) + (concat "\n" + (mapconcat 'identity + example + "\n ->\n") + "\n")) + examples + ""))))) + +;;;;; HTML Examples + +(defun paredit-insert-html-examples () + "Insert HTML for a paredit quick reference table." + (interactive) + (let ((insert-lines + (lambda (&rest lines) (dolist (line lines) (insert line) (newline)))) + (initp nil)) + (paredit-do-commands (spec keys fn examples) + (progn (if initp + (funcall insert-lines "") + (setq initp t)) + (funcall insert-lines (concat "

" spec "

")) + (funcall insert-lines "")) + (let ((name (symbol-name fn)) + (keys + (mapconcat (lambda (key) + (concat "" (paredit-html-quote key) "")) + keys + ", "))) + (funcall insert-lines "") + (funcall insert-lines (concat " ")) + (funcall insert-lines (concat " ")) + (funcall insert-lines "") + (funcall insert-lines + ""))) + (funcall insert-lines "
" keys "" name "
") + (dolist (example examples) + (let ((prefix "")) + (funcall insert-lines (concat prefix examples suffix)))) + (funcall insert-lines "
" + "" + "
")
+                (examples
+                 (mapconcat 'paredit-html-quote
+                            example
+                            (concat "
↓
")))
+                (suffix "
"))) + +(defun paredit-html-quote (string) + (with-temp-buffer + (dotimes (i (length string)) + (insert (let ((c (elt string i))) + (cond ((eq c ?\<) "<") + ((eq c ?\>) ">") + ((eq c ?\&) "&") + ((eq c ?\') "'") + ((eq c ?\") """) + (t c))))) + (buffer-string))) + +;;;; Delimiter Insertion + +(eval-and-compile + (defun paredit-conc-name (&rest strings) + (intern (apply 'concat strings))) + + (defmacro define-paredit-pair (open close name) + `(progn + (defun ,(paredit-conc-name "paredit-open-" name) (&optional n) + ,(concat "Insert a balanced " name " pair. +With a prefix argument N, put the closing " name " after N + S-expressions forward. +If the region is active, `transient-mark-mode' is enabled, and the + region's start and end fall in the same parenthesis depth, insert a + " name " pair around the region. +If in a string or a comment, insert a single " name ". +If in a character literal, do nothing. This prevents changing what was + in the character literal to a meaningful delimiter unintentionally.") + (interactive "P") + (cond ((or (paredit-in-string-p) + (paredit-in-comment-p)) + (insert ,open)) + ((not (paredit-in-char-p)) + (paredit-insert-pair n ,open ,close 'goto-char) + (save-excursion (backward-up-list) (indent-sexp))))) + (defun ,(paredit-conc-name "paredit-close-" name) () + ,(concat "Move past one closing delimiter and reindent. +\(Agnostic to the specific closing delimiter.) +If in a string or comment, insert a single closing " name ". +If in a character literal, do nothing. This prevents changing what was + in the character literal to a meaningful delimiter unintentionally.") + (interactive) + (paredit-move-past-close ,close)) + (defun ,(paredit-conc-name "paredit-close-" name "-and-newline") () + ,(concat "Move past one closing delimiter, add a newline," + " and reindent. +If there was a margin comment after the closing delimiter, preserve it + on the same line.") + (interactive) + (paredit-move-past-close-and-newline ,close)) + (defun ,(paredit-conc-name "paredit-wrap-" name) + (&optional argument) + ,(concat "Wrap the following S-expression. +See `paredit-wrap-sexp' for more details.") + (interactive "P") + (paredit-wrap-sexp argument ,open ,close)) + (add-to-list 'paredit-wrap-commands + ',(paredit-conc-name "paredit-wrap-" name))))) + +(defvar paredit-wrap-commands '(paredit-wrap-sexp) + "List of paredit commands that wrap S-expressions. +Used by `paredit-yank-pop'; for internal paredit use only.") + +(define-paredit-pair ?\( ?\) "round") +(define-paredit-pair ?\[ ?\] "square") +(define-paredit-pair ?\{ ?\} "curly") +(define-paredit-pair ?\< ?\> "angled") + +;;; Aliases for the old names. + +(defalias 'paredit-open-parenthesis 'paredit-open-round) +(defalias 'paredit-close-parenthesis 'paredit-close-round) +(defalias 'paredit-close-parenthesis-and-newline + 'paredit-close-round-and-newline) + +(defalias 'paredit-open-bracket 'paredit-open-square) +(defalias 'paredit-close-bracket 'paredit-close-square) +(defalias 'paredit-close-bracket-and-newline + 'paredit-close-square-and-newline) + +(defun paredit-move-past-close (close) + (paredit-move-past-close-and close + (lambda () + (paredit-blink-paren-match nil)))) + +(defun paredit-move-past-close-and-newline (close) + (paredit-move-past-close-and close + (lambda () + (let ((comment.point (paredit-find-comment-on-line))) + (newline) + (if comment.point + (save-excursion + (forward-line -1) + (end-of-line) + (indent-to (cdr comment.point)) + (insert (car comment.point))))) + (lisp-indent-line) + (paredit-ignore-sexp-errors (indent-sexp)) + (paredit-blink-paren-match t)))) + +(defun paredit-move-past-close-and (close if-moved) + (if (or (paredit-in-string-p) + (paredit-in-comment-p)) + (insert close) + (if (paredit-in-char-p) (forward-char)) + (paredit-move-past-close-and-reindent close) + (funcall if-moved))) + +(defun paredit-find-comment-on-line () + "Find a margin comment on the current line. +Return nil if there is no such comment or if there is anything but + whitespace until such a comment. +If such a comment exists, delete the comment (including all leading + whitespace) and return a cons whose car is the comment as a string + and whose cdr is the point of the comment's initial semicolon, + relative to the start of the line." + (save-excursion + (paredit-skip-whitespace t (point-at-eol)) + (and (eq ?\; (char-after)) + (not (eq ?\; (char-after (1+ (point))))) + (not (or (paredit-in-string-p) + (paredit-in-char-p))) + (let* ((start ;Move to before the semicolon. + (progn (backward-char) (point))) + (comment + (buffer-substring start (point-at-eol)))) + (paredit-skip-whitespace nil (point-at-bol)) + (delete-region (point) (point-at-eol)) + (cons comment (- start (point-at-bol))))))) + +(defun paredit-insert-pair (n open close forward) + (let* ((regionp + (and (paredit-region-active-p) + (paredit-region-safe-for-insert-p))) + (end + (and regionp + (not n) + (prog1 (region-end) (goto-char (region-beginning)))))) + (let ((spacep (paredit-space-for-delimiter-p nil open))) + (if spacep (insert " ")) + (insert open) + (save-excursion + ;; Move past the desired region. + (cond (n + (funcall forward + (paredit-scan-sexps-hack (point) + (prefix-numeric-value n)))) + (regionp + (funcall forward (+ end (if spacep 2 1))))) + ;; The string case can happen if we are inserting string + ;; delimiters. The comment case may happen by moving to the + ;; end of a buffer that has a comment with no trailing newline. + (if (and (not (paredit-in-string-p)) + (paredit-in-comment-p)) + (newline)) + (insert close) + (if (paredit-space-for-delimiter-p t close) + (insert " ")))))) + +;++ This needs a better name... + +(defun paredit-scan-sexps-hack (point n) + (save-excursion + (goto-char point) + (let ((direction (if (< 0 n) +1 -1)) + (magnitude (abs n)) + (count 0)) + (catch 'exit + (while (< count magnitude) + (let ((p + (paredit-handle-sexp-errors (scan-sexps (point) direction) + nil))) + (if (not p) (throw 'exit nil)) + (goto-char p)) + (setq count (+ count 1))))) + (point))) + +(defun paredit-region-safe-for-insert-p () + (save-excursion + (let ((beginning (region-beginning)) + (end (region-end))) + (goto-char beginning) + (let* ((beginning-state (paredit-current-parse-state)) + (end-state + (parse-partial-sexp beginning end nil nil beginning-state))) + (and (= (nth 0 beginning-state) ; 0. depth in parens + (nth 0 end-state)) + (eq (nth 3 beginning-state) ; 3. non-nil if inside a + (nth 3 end-state)) ; string + (eq (nth 4 beginning-state) ; 4. comment status, yada + (nth 4 end-state)) + (eq (nth 5 beginning-state) ; 5. t if following char + (nth 5 end-state))))))) ; quote + +(defvar paredit-space-for-delimiter-predicates nil + "List of predicates for whether to put space by delimiter at point. +Each predicate is a function that is is applied to two arguments, ENDP + and DELIMITER, and that returns a boolean saying whether to put a + space next to the delimiter -- before/after the delimiter if ENDP is + false/true, respectively. +If any predicate returns false, no space is inserted: every predicate + has veto power. +Each predicate may assume that the point is not at the beginning/end of + the buffer, and that the point is preceded/followed by a word + constituent, symbol constituent, string quote, or delimiter matching + DELIMITER, if ENDP is false/true, respectively. +Each predicate should examine only text before/after the point if ENDP is + false/true, respectively.") + +(defun paredit-space-for-delimiter-p (endp delimiter) + ;; If at the buffer limit, don't insert a space. If there is a word, + ;; symbol, other quote, or non-matching parenthesis delimiter (i.e. a + ;; close when want an open the string or an open when we want to + ;; close the string), do insert a space. + (and (not (if endp (eobp) (bobp))) + (memq (char-syntax (if endp (char-after) (char-before))) + (list ?w ?_ ?\" + (let ((matching (matching-paren delimiter))) + (and matching (char-syntax matching))) + (and (not endp) + (eq ?\" (char-syntax delimiter)) + ?\) ))) + (catch 'exit + (dolist (predicate paredit-space-for-delimiter-predicates) + (if (not (funcall predicate endp delimiter)) + (throw 'exit nil))) + t))) + +(defun paredit-move-past-close-and-reindent (close) + (let ((open (paredit-missing-close))) + (if open + (if (eq close (matching-paren open)) + (save-excursion + (message "Missing closing delimiter: %c" close) + (insert close)) + (error "Mismatched missing closing delimiter: %c ... %c" + open close)))) + (up-list) + (if (catch 'return ; This CATCH returns T if it + (while t ; should delete leading spaces + (save-excursion ; and NIL if not. + (let ((before-paren (1- (point)))) + (back-to-indentation) + (cond ((not (eq (point) before-paren)) + ;; Can't call PAREDIT-DELETE-LEADING-WHITESPACE + ;; here -- we must return from SAVE-EXCURSION + ;; first. + (throw 'return t)) + ((save-excursion (forward-line -1) + (end-of-line) + (paredit-in-comment-p)) + ;; Moving the closing delimiter any further + ;; would put it into a comment, so we just + ;; indent the closing delimiter where it is and + ;; abort the loop, telling its continuation that + ;; no leading whitespace should be deleted. + (lisp-indent-line) + (throw 'return nil)) + (t (delete-indentation))))))) + (paredit-delete-leading-whitespace))) + +(defun paredit-missing-close () + (save-excursion + (paredit-handle-sexp-errors (backward-up-list) + (error "Not inside a list.")) + (let ((open (char-after))) + (paredit-handle-sexp-errors (progn (forward-sexp) nil) + open)))) + +(defun paredit-delete-leading-whitespace () + ;; This assumes that we're on the closing delimiter already. + (save-excursion + (backward-char) + (while (let ((syn (char-syntax (char-before)))) + (and (or (eq syn ?\ ) (eq syn ?-)) ; whitespace syntax + ;; The above line is a perfect example of why the + ;; following test is necessary. + (not (paredit-in-char-p (1- (point)))))) + (delete-char -1)))) + +(defun paredit-blink-paren-match (another-line-p) + (if (and blink-matching-paren + (or (not show-paren-mode) another-line-p)) + (paredit-ignore-sexp-errors + (save-excursion + (backward-sexp) + (forward-sexp) + ;; SHOW-PAREN-MODE inhibits any blinking, so we disable it + ;; locally here. + (let ((show-paren-mode nil)) + (blink-matching-open)))))) + +(defun paredit-doublequote (&optional n) + "Insert a pair of double-quotes. +With a prefix argument N, wrap the following N S-expressions in + double-quotes, escaping intermediate characters if necessary. +If the region is active, `transient-mark-mode' is enabled, and the + region's start and end fall in the same parenthesis depth, insert a + pair of double-quotes around the region, again escaping intermediate + characters if necessary. +Inside a comment, insert a literal double-quote. +At the end of a string, move past the closing double-quote. +In the middle of a string, insert a backslash-escaped double-quote. +If in a character literal, do nothing. This prevents accidentally + changing a what was in the character literal to become a meaningful + delimiter unintentionally." + (interactive "P") + (cond ((paredit-in-string-p) + (if (eq (point) (- (paredit-enclosing-string-end) 1)) + (forward-char) ; Just move past the closing quote. + ;; Don't split a \x into an escaped backslash and a string end. + (if (paredit-in-string-escape-p) (forward-char)) + (insert ?\\ ?\" ))) + ((paredit-in-comment-p) + (insert ?\" )) + ((not (paredit-in-char-p)) + (paredit-insert-pair n ?\" ?\" 'paredit-forward-for-quote)))) + +(defun paredit-meta-doublequote (&optional n) + "Move to the end of the string. +If not in a string, act as `paredit-doublequote'; if not prefix argument + is specified and the region is not active or `transient-mark-mode' is + disabled, the default is to wrap one S-expression, however, not zero." + (interactive "P") + (if (not (paredit-in-string-p)) + (paredit-doublequote (or n (and (not (paredit-region-active-p)) 1))) + (goto-char (paredit-enclosing-string-end)))) + +(defun paredit-meta-doublequote-and-newline (&optional n) + "Move to the end of the string, insert a newline, and indent. +If not in a string, act as `paredit-doublequote'; if not prefix argument + is specified and the region is not active or `transient-mark-mode' is + disabled, the default is to wrap one S-expression, however, not zero." + (interactive "P") + (if (not (paredit-in-string-p)) + (paredit-doublequote (or n (and (not (paredit-region-active-p)) 1))) + (progn (goto-char (paredit-enclosing-string-end)) + (newline) + (lisp-indent-line) + (paredit-ignore-sexp-errors (indent-sexp))))) + +(defun paredit-forward-for-quote (end) + (let ((state (paredit-current-parse-state))) + (while (< (point) end) + (let ((new-state (parse-partial-sexp (point) (1+ (point)) + nil nil state))) + (if (paredit-in-string-p new-state) + (if (not (paredit-in-string-escape-p)) + (setq state new-state) + ;; Escape character: turn it into an escaped escape + ;; character by appending another backslash. + (insert ?\\ ) + ;; Now the point is after both escapes, and we want to + ;; rescan from before the first one to after the second + ;; one. + (setq state + (parse-partial-sexp (- (point) 2) (point) + nil nil state)) + ;; Advance the end point, since we just inserted a new + ;; character. + (setq end (1+ end))) + ;; String: escape by inserting a backslash before the quote. + (backward-char) + (insert ?\\ ) + ;; The point is now between the escape and the quote, and we + ;; want to rescan from before the escape to after the quote. + (setq state + (parse-partial-sexp (1- (point)) (1+ (point)) + nil nil state)) + ;; Advance the end point for the same reason as above. + (setq end (1+ end))))))) + +;;;; Escape Insertion + +(defun paredit-backslash () + "Insert a backslash followed by a character to escape." + (interactive) + (cond ((paredit-in-string-p) (paredit-backslash-interactive)) + ((paredit-in-comment-p) (insert ?\\)) + ((paredit-in-char-p) (forward-char) (paredit-backslash-interactive)) + (t (paredit-backslash-interactive)))) + +(defun paredit-backslash-interactive () + (insert ?\\ ) + ;; Read a character to insert after the backslash. If anything + ;; goes wrong -- the user hits delete (entering the rubout + ;; `character'), aborts with C-g, or enters non-character input + ;; -- then delete the backslash to avoid a dangling escape. + (let ((delete-p t)) + (unwind-protect + (let ((char (read-char "Character to escape: " t))) + (if (not (eq char ?\^?)) + (progn (message "Character to escape: %c" char) + (insert char) + (setq delete-p nil)))) + (if delete-p + (progn (message "Deleting escape.") + (delete-char -1)))))) + +(defun paredit-newline () + "Insert a newline and indent it. +This is like `newline-and-indent', but it not only indents the line + that the point is on but also the S-expression following the point, + if there is one. +Move forward one character first if on an escaped character. +If in a string, just insert a literal newline. +If in a comment and if followed by invalid structure, call + `indent-new-comment-line' to keep the invalid structure in a + comment." + (interactive) + (cond ((paredit-in-string-p) + (newline)) + ((paredit-in-comment-p) + (if (paredit-region-ok-p (point) (point-at-eol)) + (progn (newline-and-indent) + (paredit-ignore-sexp-errors (indent-sexp))) + (indent-new-comment-line))) + (t + (if (paredit-in-char-p) + (forward-char)) + (newline-and-indent) + ;; Indent the following S-expression, but don't signal an + ;; error if there's only a closing delimiter after the point. + (paredit-ignore-sexp-errors (indent-sexp))))) + +(defun paredit-electric-indent-mode-p () + "True if Electric Indent Mode is on, false if not. +Electric Indent Mode is generally not compatible with paredit and + users are advised to disable it, since paredit does essentially + everything it tries to do better. +However, to mitigate the negative user experience of combining + Electric Indent Mode with paredit, the default key bindings for + RET and C-j in paredit are exchanged depending on whether + Electric Indent Mode is enabled." + (and (boundp 'electric-indent-mode) + electric-indent-mode)) + +(defun paredit-RET () + "Default key binding for RET in Paredit Mode. +Normally, inserts a newline, like traditional Emacs RET. +With Electric Indent Mode enabled, inserts a newline and indents + the new line, as well as any subexpressions of it on subsequent + lines." + (interactive) + (if (paredit-electric-indent-mode-p) + (let ((electric-indent-mode nil)) + (paredit-newline)) + (newline))) + +(defun paredit-C-j () + "Default key binding for C-j in Paredit Mode. +Normally, inserts a newline and indents + the new line, as well as any subexpressions of it on subsequent + lines. +With Electric Indent Mode enabled, inserts a newline, like + traditional Emacs RET." + (interactive) + (if (paredit-electric-indent-mode-p) + (let ((electric-indent-mode nil)) + (newline)) + (paredit-newline))) + +(defun paredit-reindent-defun (&optional argument) + "Reindent the definition that the point is on. +If the point is in a string or a comment, fill the paragraph instead, + and with a prefix argument, justify as well." + (interactive "P") + (if (or (paredit-in-string-p) + (paredit-in-comment-p)) + (if (memq fill-paragraph-function '(t nil)) + (lisp-fill-paragraph argument) + (funcall fill-paragraph-function argument)) + (paredit-preserving-column + (save-excursion + (end-of-defun) + (beginning-of-defun) + (indent-sexp))))) + +;;;; Comment Insertion + +(defun paredit-semicolon (&optional n) + "Insert a semicolon. +With a prefix argument N, insert N semicolons. +If in a string, do just that and nothing else. +If in a character literal, move to the beginning of the character + literal before inserting the semicolon. +If the enclosing list ends on the line after the point, break the line + after the last S-expression following the point. +If a list begins on the line after the point but ends on a different + line, break the line after the last S-expression following the point + before the list." + (interactive "p") + (if (or (paredit-in-string-p) (paredit-in-comment-p)) + (insert (make-string (or n 1) ?\; )) + (if (paredit-in-char-p) + (backward-char 2)) + (let ((line-break-point (paredit-semicolon-find-line-break-point))) + (if line-break-point + (paredit-semicolon-with-line-break line-break-point (or n 1)) + (insert (make-string (or n 1) ?\; )))))) + +(defun paredit-semicolon-find-line-break-point () + (and (not (eolp)) ;Implies (not (eobp)). + (let ((eol (point-at-eol))) + (save-excursion + (catch 'exit + (while t + (let ((line-break-point (point))) + (cond ((paredit-handle-sexp-errors (progn (forward-sexp) t) + nil) + ;; Successfully advanced by an S-expression. + ;; If that S-expression started on this line + ;; and ended on another one, break here. + (cond ((not (eq eol (point-at-eol))) + (throw 'exit + (and (save-excursion + (backward-sexp) + (eq eol (point-at-eol))) + line-break-point))) + ((eobp) + (throw 'exit nil)))) + ((save-excursion + (paredit-skip-whitespace t (point-at-eol)) + (or (eolp) (eobp) (eq (char-after) ?\;))) + ;; Can't move further, but there's no closing + ;; delimiter we're about to clobber -- either + ;; it's on the next line or we're at the end of + ;; the buffer. Don't break the line. + (throw 'exit nil)) + (t + ;; Can't move because we hit a delimiter at the + ;; end of this line. Break here. + (throw 'exit line-break-point)))))))))) + +(defun paredit-semicolon-with-line-break (line-break-point n) + (let ((line-break-marker (make-marker))) + (set-marker line-break-marker line-break-point) + (set-marker-insertion-type line-break-marker t) + (insert (make-string (or n 1) ?\; )) + (save-excursion + (goto-char line-break-marker) + (set-marker line-break-marker nil) + (newline) + (lisp-indent-line) + ;; This step is redundant if we are inside a list, but even if we + ;; are at the top level, we want at least to indent whatever we + ;; bumped off the line. + (paredit-ignore-sexp-errors (indent-sexp)) + (paredit-indent-sexps)))) + +;;; This is all a horrible, horrible hack, primarily for GNU Emacs 21, +;;; in which there is no `comment-or-uncomment-region'. + +(autoload 'comment-forward "newcomment") +(autoload 'comment-normalize-vars "newcomment") +(autoload 'comment-region "newcomment") +(autoload 'comment-search-forward "newcomment") +(autoload 'uncomment-region "newcomment") + +(defun paredit-initialize-comment-dwim () + (require 'newcomment) + (if (not (fboundp 'comment-or-uncomment-region)) + (defalias 'comment-or-uncomment-region + (lambda (beginning end &optional argument) + (interactive "*r\nP") + (if (save-excursion (goto-char beginning) + (comment-forward (point-max)) + (<= end (point))) + (uncomment-region beginning end argument) + (comment-region beginning end argument))))) + (defalias 'paredit-initialize-comment-dwim 'comment-normalize-vars) + (comment-normalize-vars)) + +(defvar paredit-comment-prefix-toplevel ";;; " + "String of prefix for top-level comments aligned at the left margin.") + +(defvar paredit-comment-prefix-code ";; " + "String of prefix for comments indented at the same depth as code.") + +(defvar paredit-comment-prefix-margin ";" + "String of prefix for comments on the same line as code in the margin.") + +(defun paredit-comment-dwim (&optional argument) + "Call the Lisp comment command you want (Do What I Mean). +This is like `comment-dwim', but it is specialized for Lisp editing. +If transient mark mode is enabled and the mark is active, comment or + uncomment the selected region, depending on whether it was entirely + commented not not already. +If there is already a comment on the current line, with no prefix + argument, indent to that comment; with a prefix argument, kill that + comment. +Otherwise, insert a comment appropriate for the context and ensure that + any code following the comment is moved to the next line. +At the top level, where indentation is calculated to be at column 0, + insert a triple-semicolon comment; within code, where the indentation + is calculated to be non-zero, and on the line there is either no code + at all or code after the point, insert a double-semicolon comment; + and if the point is after all code on the line, insert a single- + semicolon margin comment at `comment-column'." + (interactive "*P") + (paredit-initialize-comment-dwim) + (cond ((paredit-region-active-p) + (comment-or-uncomment-region (region-beginning) + (region-end) + argument)) + ((paredit-comment-on-line-p) + (if argument + (comment-kill (if (integerp argument) argument nil)) + (comment-indent))) + (t (paredit-insert-comment)))) + +(defun paredit-comment-on-line-p () + "True if there is a comment on the line following point. +This is expected to be called only in `paredit-comment-dwim'; do not + call it elsewhere." + (save-excursion + (beginning-of-line) + (let ((comment-p nil)) + ;; Search forward for a comment beginning. If there is one, set + ;; COMMENT-P to true; if not, it will be nil. + (while (progn + (setq comment-p ;t -> no error + (comment-search-forward (point-at-eol) t)) + (and comment-p + (or (paredit-in-string-p) + (paredit-in-char-p (1- (point)))))) + (forward-char)) + comment-p))) + +(defun paredit-insert-comment () + (let ((code-after-p + (save-excursion (paredit-skip-whitespace t (point-at-eol)) + (not (eolp)))) + (code-before-p + (save-excursion (paredit-skip-whitespace nil (point-at-bol)) + (not (bolp))))) + (cond ((and (bolp) + (let ((indent + (let ((indent (calculate-lisp-indent))) + (if (consp indent) (car indent) indent)))) + (and indent (zerop indent)))) + ;; Top-level comment + (if code-after-p (save-excursion (newline))) + (insert paredit-comment-prefix-toplevel)) + ((or code-after-p (not code-before-p)) + ;; Code comment + (if code-before-p + (newline-and-indent) + (lisp-indent-line)) + (insert paredit-comment-prefix-code) + (if code-after-p + (save-excursion + (newline) + (lisp-indent-line) + (paredit-indent-sexps)))) + (t + ;; Margin comment + (indent-to comment-column 1) ; 1 -> force one leading space + (insert paredit-comment-prefix-margin))))) + +;;;; Character Deletion + +(defun paredit-delete-char (&optional argument) + "Delete a character forward or move forward over a delimiter. +If on an opening S-expression delimiter, move forward into the + S-expression. +If on a closing S-expression delimiter, refuse to delete unless the + S-expression is empty, in which case delete the whole S-expression. +With a numeric prefix argument N, delete N characters forward. +With a `C-u' prefix argument, simply delete a character forward, + without regard for delimiter balancing. + +Like `delete-char', ignores `delete-active-region'." + (interactive "P") + (let ((delete-active-region nil)) + (paredit-forward-delete argument))) + +(defun paredit-delete-active-region-p () + "True if the region is active and to be deleted." + (and (paredit-region-active-p) + (boundp 'delete-active-region) + (eq delete-active-region t))) + +(defun paredit-kill-active-region-p () + "True if the region is active and to be killed." + (and (paredit-region-active-p) + (boundp 'delete-active-region) + (eq delete-active-region 'kill))) + +(defun paredit-forward-delete (&optional argument) + "Delete a character forward or move forward over a delimiter. +If on an opening S-expression delimiter, move forward into the + S-expression. +If on a closing S-expression delimiter, refuse to delete unless the + S-expression is empty, in which case delete the whole S-expression. +With a numeric prefix argument N, delete N characters forward. +With a `C-u' prefix argument, simply delete a character forward, + without regard for delimiter balancing. + +If `delete-active-region' is enabled and the mark is active and + no prefix argument is specified, act as `paredit-delete-region' + or `paredit-kill-region' as appropriate instead." + (interactive "P") + (cond ((consp argument) + (delete-char +1)) + ((integerp argument) + (let ((delete-active-region nil)) + (if (< argument 0) + (paredit-backward-delete argument) + (while (> argument 0) + (paredit-forward-delete) + (setq argument (- argument 1)))))) + ((paredit-delete-active-region-p) + (paredit-delete-region (region-beginning) (region-end))) + ((paredit-kill-active-region-p) + (paredit-kill-region (region-beginning) (region-end))) + ((eobp) + (delete-char +1)) + ((paredit-in-string-p) + (paredit-forward-delete-in-string)) + ((paredit-in-comment-p) + (paredit-forward-delete-in-comment)) + ((paredit-in-char-p) ; Escape -- delete both chars. + (delete-char -1) + (delete-char +1)) + ((eq (char-after) ?\\ ) ; ditto + (delete-char +2)) + ((let ((syn (char-syntax (char-after)))) + (or (eq syn ?\( ) + (eq syn ?\" ))) + (if (save-excursion + (paredit-handle-sexp-errors (progn (forward-sexp) t) + nil)) + (forward-char) + (message "Deleting spurious opening delimiter.") + (delete-char +1))) + ((and (not (paredit-in-char-p (1- (point)))) + (eq (char-syntax (char-after)) ?\) ) + (eq (char-before) (matching-paren (char-after)))) + (delete-char -1) ; Empty list -- delete both + (delete-char +1)) ; delimiters. + ((eq ?\; (char-after)) + (paredit-forward-delete-comment-start)) + ((eq (char-syntax (char-after)) ?\) ) + (if (paredit-handle-sexp-errors + (save-excursion (forward-char) (backward-sexp) t) + nil) + (message "End of list!") + (progn + (message "Deleting spurious closing delimiter.") + (delete-char +1)))) + ;; Just delete a single character, if it's not a closing + ;; delimiter. (The character literal case is already handled + ;; by now.) + (t (delete-char +1)))) + +(defun paredit-forward-delete-in-string () + (let ((start+end (paredit-string-start+end-points))) + (cond ((not (eq (point) (cdr start+end))) + ;; If it's not the close-quote, it's safe to delete. But + ;; first handle the case that we're in a string escape. + (cond ((paredit-in-string-escape-p) + ;; We're right after the backslash, so backward + ;; delete it before deleting the escaped character. + (delete-char -1)) + ((eq (char-after) ?\\ ) + ;; If we're not in a string escape, but we are on a + ;; backslash, it must start the escape for the next + ;; character, so delete the backslash before deleting + ;; the next character. + (delete-char +1))) + (delete-char +1)) + ((eq (1- (point)) (car start+end)) + ;; If it is the close-quote, delete only if we're also right + ;; past the open-quote (i.e. it's empty), and then delete + ;; both quotes. Otherwise we refuse to delete it. + (delete-char -1) + (delete-char +1))))) + +(defun paredit-check-forward-delete-in-comment () + ;; Point is in a comment, possibly at eol. We are about to delete + ;; some characters forward; if we are at eol, we are about to delete + ;; the line break. Refuse to do so if if moving the next line into + ;; the comment would break structure. + (if (eolp) + (let ((next-line-start (point-at-bol 2)) + (next-line-end (point-at-eol 2))) + (paredit-check-region next-line-start next-line-end)))) + +(defun paredit-forward-delete-in-comment () + (paredit-check-forward-delete-in-comment) + (delete-char +1)) + +(defun paredit-forward-delete-comment-start () + ;; Point precedes a comment start (not at eol). Refuse to delete a + ;; comment start if the comment contains unbalanced junk. + (paredit-check-region (+ (point) 1) (point-at-eol)) + (delete-char +1)) + +(defun paredit-backward-delete (&optional argument) + "Delete a character backward or move backward over a delimiter. +If on a closing S-expression delimiter, move backward into the + S-expression. +If on an opening S-expression delimiter, refuse to delete unless the + S-expression is empty, in which case delete the whole S-expression. +With a numeric prefix argument N, delete N characters backward. +With a `C-u' prefix argument, simply delete a character backward, + without regard for delimiter balancing. + +If `delete-active-region' is enabled and the mark is active and + no prefix argument is specified, act as `paredit-delete-region' + or `paredit-kill-region' as appropriate instead." + (interactive "P") + (cond ((consp argument) + ;++ Should this untabify? + (delete-char -1)) + ((integerp argument) + (let ((delete-active-region nil)) + (if (< argument 0) + (paredit-forward-delete (- 0 argument)) + (while (> argument 0) + (paredit-backward-delete) + (setq argument (- argument 1)))))) + ((paredit-delete-active-region-p) + (paredit-delete-region (region-beginning) (region-end))) + ((paredit-kill-active-region-p) + (paredit-kill-region (region-beginning) (region-end))) + ((bobp) + (delete-char -1)) + ((paredit-in-string-p) + (paredit-backward-delete-in-string)) + ((paredit-in-comment-p) + (paredit-backward-delete-in-comment)) + ((paredit-in-char-p) ; Escape -- delete both chars. + (delete-char -1) + (delete-char +1)) + ((paredit-in-char-p (1- (point))) + (delete-char -2)) ; ditto + ((let ((syn (char-syntax (char-before)))) + (or (eq syn ?\) ) + (eq syn ?\" ))) + (if (save-excursion + (paredit-handle-sexp-errors (progn (backward-sexp) t) + nil)) + (backward-char) + (message "Deleting spurious closing delimiter.") + (delete-char -1))) + ((and (eq (char-syntax (char-before)) ?\( ) + (eq (char-after) (matching-paren (char-before)))) + (delete-char -1) ; Empty list -- delete both + (delete-char +1)) ; delimiters. + ((bolp) + (paredit-backward-delete-maybe-comment-end)) + ((eq (char-syntax (char-before)) ?\( ) + (if (paredit-handle-sexp-errors + (save-excursion (backward-char) (forward-sexp) t) + nil) + (message "Beginning of list!") + (progn + (message "Deleting spurious closing delimiter.") + (delete-char -1)))) + ;; Delete it, unless it's an opening delimiter. The case of + ;; character literals is already handled by now. + (t + ;; Turn off the @#&*&!^&(%^ botch in GNU Emacs 24 that changed + ;; `backward-delete-char' and `backward-delete-char-untabify' + ;; semantically so that they delete the region in transient + ;; mark mode. + (let ((delete-active-region nil)) + (backward-delete-char-untabify +1))))) + +(defun paredit-backward-delete-in-string () + (let ((start+end (paredit-string-start+end-points))) + (cond ((not (eq (1- (point)) (car start+end))) + ;; If it's not the open-quote, it's safe to delete. + (if (paredit-in-string-escape-p) + ;; If we're on a string escape, since we're about to + ;; delete the backslash, we must first delete the + ;; escaped char. + (delete-char +1)) + (delete-char -1) + (if (paredit-in-string-escape-p) + ;; If, after deleting a character, we find ourselves in + ;; a string escape, we must have deleted the escaped + ;; character, and the backslash is behind the point, so + ;; backward delete it. + (delete-char -1))) + ((eq (point) (cdr start+end)) + ;; If it is the open-quote, delete only if we're also right + ;; past the close-quote (i.e. it's empty), and then delete + ;; both quotes. Otherwise we refuse to delete it. + (delete-char -1) + (delete-char +1))))) + +(defun paredit-backward-delete-in-comment () + ;; Point is in a comment, possibly just after the comment start. + ;; Refuse to delete a comment start if the comment contains + ;; unbalanced junk. + (if (save-excursion + (backward-char) + ;; Must call `paredit-in-string-p' before + ;; `paredit-in-comment-p'. + (not (or (paredit-in-string-p) (paredit-in-comment-p)))) + (paredit-check-region (point) (point-at-eol))) + (backward-delete-char-untabify +1)) + +(defun paredit-backward-delete-maybe-comment-end () + ;; Point is at bol, possibly just after a comment end (i.e., the + ;; previous line may have had a line comment). Refuse to delete a + ;; comment end if moving the current line into the previous line's + ;; comment would break structure. + (if (save-excursion + (backward-char) + (and (not (paredit-in-string-p)) (paredit-in-comment-p))) + (paredit-check-region (point-at-eol) (point-at-bol))) + (delete-char -1)) + +;;;; Killing + +(defun paredit-kill (&optional argument) + "Kill a line as if with `kill-line', but respecting delimiters. +In a string, act exactly as `kill-line' but do not kill past the + closing string delimiter. +On a line with no S-expressions on it starting after the point or + within a comment, act exactly as `kill-line'. +Otherwise, kill all S-expressions that start after the point. +With a `C-u' prefix argument, just do the standard `kill-line'. +With a numeric prefix argument N, do `kill-line' that many times." + (interactive "P") + (cond (argument + (kill-line (if (integerp argument) argument 1))) + ((paredit-in-string-p) + (paredit-kill-line-in-string)) + ((paredit-in-comment-p) + (paredit-kill-line-in-comment)) + ((save-excursion (paredit-skip-whitespace t (point-at-eol)) + (or (eolp) (eq (char-after) ?\; ))) + ;** Be careful about trailing backslashes. + (if (paredit-in-char-p) + (backward-char)) + (kill-line)) + (t (paredit-kill-sexps-on-line)))) + +(defun paredit-kill-line-in-string () + (if (save-excursion (paredit-skip-whitespace t (point-at-eol)) + (eolp)) + (kill-line) + (save-excursion + ;; Be careful not to split an escape sequence. + (if (paredit-in-string-escape-p) + (backward-char)) + (kill-region (point) + (min (point-at-eol) + (cdr (paredit-string-start+end-points))))))) + +(defun paredit-kill-line-in-comment () + ;; The variable `kill-whole-line' is not relevant: the point is in a + ;; comment, and hence not at the beginning of the line. + (paredit-check-forward-delete-in-comment) + (kill-line)) + +(defun paredit-kill-sexps-on-line () + (if (paredit-in-char-p) ; Move past the \ and prefix. + (backward-char 2)) ; (# in Scheme/CL, ? in elisp) + (let ((beginning (point)) + (eol (point-at-eol))) + (let ((end-of-list-p (paredit-forward-sexps-to-kill beginning eol))) + ;; If we got to the end of the list and it's on the same line, + ;; move backward past the closing delimiter before killing. (This + ;; allows something like killing the whitespace in ( ).) + (if end-of-list-p (progn (up-list) (backward-char))) + (if kill-whole-line + (paredit-kill-sexps-on-whole-line beginning) + (kill-region beginning + ;; If all of the S-expressions were on one line, + ;; i.e. we're still on that line after moving past + ;; the last one, kill the whole line, including + ;; any comments; otherwise just kill to the end of + ;; the last S-expression we found. Be sure, + ;; though, not to kill any closing parentheses. + (if (and (not end-of-list-p) + (eq (point-at-eol) eol)) + eol + (point))))))) + +;;; Please do not try to understand this code unless you have a VERY +;;; good reason to do so. I gave up trying to figure it out well +;;; enough to explain it, long ago. + +(defun paredit-forward-sexps-to-kill (beginning eol) + (let ((end-of-list-p nil) + (firstp t)) + ;; Move to the end of the last S-expression that started on this + ;; line, or to the closing delimiter if the last S-expression in + ;; this list is on the line. + (catch 'return + (while t + ;; This and the `kill-whole-line' business below fix a bug that + ;; inhibited any S-expression at the very end of the buffer + ;; (with no trailing newline) from being deleted. It's a + ;; bizarre fix that I ought to document at some point, but I am + ;; too busy at the moment to do so. + (if (and kill-whole-line (eobp)) (throw 'return nil)) + (save-excursion + (paredit-handle-sexp-errors (forward-sexp) + (up-list) + (setq end-of-list-p (eq (point-at-eol) eol)) + (throw 'return nil)) + (if (or (and (not firstp) + (not kill-whole-line) + (eobp)) + (paredit-handle-sexp-errors + (progn (backward-sexp) nil) + t) + (not (eq (point-at-eol) eol))) + (throw 'return nil))) + (forward-sexp) + (if (and firstp + (not kill-whole-line) + (eobp)) + (throw 'return nil)) + (setq firstp nil))) + end-of-list-p)) + +(defun paredit-kill-sexps-on-whole-line (beginning) + (kill-region beginning + (or (save-excursion ; Delete trailing indentation... + (paredit-skip-whitespace t) + (and (not (eq (char-after) ?\; )) + (point))) + ;; ...or just use the point past the newline, if + ;; we encounter a comment. + (point-at-eol))) + (cond ((save-excursion (paredit-skip-whitespace nil (point-at-bol)) + (bolp)) + ;; Nothing but indentation before the point, so indent it. + (lisp-indent-line)) + ((eobp) nil) ; Protect the CHAR-SYNTAX below against NIL. + ;; Insert a space to avoid invalid joining if necessary. + ((let ((syn-before (char-syntax (char-before))) + (syn-after (char-syntax (char-after)))) + (or (and (eq syn-before ?\) ) ; Separate opposing + (eq syn-after ?\( )) ; parentheses, + (and (eq syn-before ?\" ) ; string delimiter + (eq syn-after ?\" )) ; pairs, + (and (memq syn-before '(?_ ?w)) ; or word or symbol + (memq syn-after '(?_ ?w))))) ; constituents. + (insert " ")))) + +;;;;; Killing Words + +;;; This is tricky and asymmetrical because backward parsing is +;;; extraordinarily difficult or impossible, so we have to implement +;;; killing in both directions by parsing forward. + +(defun paredit-forward-kill-word (&optional argument) + "Kill a word forward, skipping over intervening delimiters." + (interactive "p") + (let ((argument (or argument 1))) + (if (< argument 0) + (paredit-backward-kill-word (- argument)) + (dotimes (i argument) + (let ((beginning (point))) + (skip-syntax-forward " -") + (let* ((parse-state (paredit-current-parse-state)) + (state (paredit-kill-word-state parse-state 'char-after))) + (while (not (or (eobp) + (eq ?w (char-syntax (char-after))))) + (setq parse-state + (progn (forward-char 1) (paredit-current-parse-state)) + ;; XXX Why did I comment this out? + ;; (parse-partial-sexp (point) (1+ (point)) + ;; nil nil parse-state) + ) + (let* ((old-state state) + (new-state + (paredit-kill-word-state parse-state 'char-after))) + (cond ((not (eq old-state new-state)) + (setq parse-state + (paredit-kill-word-hack old-state + new-state + parse-state)) + (setq state + (paredit-kill-word-state parse-state + 'char-after)) + (setq beginning (point))))))) + (goto-char beginning) + (kill-word 1)))))) + +(defun paredit-backward-kill-word (&optional argument) + "Kill a word backward, skipping over any intervening delimiters." + (interactive "p") + (let ((argument (or argument 1))) + (if (< argument 0) + (paredit-forward-kill-word (- argument)) + (dotimes (i argument) + (if (not (or (bobp) + (eq (char-syntax (char-before)) ?w))) + (let ((end (point))) + (backward-word 1) + (forward-word 1) + (goto-char (min end (point))) + (let* ((parse-state (paredit-current-parse-state)) + (state + (paredit-kill-word-state parse-state 'char-before))) + (while (and (< (point) end) + (progn + (setq parse-state + (parse-partial-sexp (point) (1+ (point)) + nil nil parse-state)) + (or (eq state + (paredit-kill-word-state parse-state + 'char-before)) + (progn (backward-char 1) nil))))) + (if (and (eq state 'comment) + (eq ?\# (char-after (point))) + (eq ?\| (char-before (point)))) + (backward-char 1))))) + (backward-kill-word 1))))) + +;;;;;; Word-Killing Auxiliaries + +(defun paredit-kill-word-state (parse-state adjacent-char-fn) + (cond ((paredit-in-comment-p parse-state) 'comment) + ((paredit-in-string-p parse-state) 'string) + ((memq (char-syntax (funcall adjacent-char-fn)) + '(?\( ?\) )) + 'delimiter) + (t 'other))) + +;;; This optionally advances the point past any comment delimiters that +;;; should probably not be touched, based on the last state change and +;;; the characters around the point. It returns a new parse state, +;;; starting from the PARSE-STATE parameter. + +(defun paredit-kill-word-hack (old-state new-state parse-state) + (cond ((and (not (eq old-state 'comment)) + (not (eq new-state 'comment)) + (not (paredit-in-string-escape-p)) + (eq ?\# (char-before)) + (eq ?\| (char-after))) + (forward-char 1) + (paredit-current-parse-state) +;; (parse-partial-sexp (point) (1+ (point)) +;; nil nil parse-state) + ) + ((and (not (eq old-state 'comment)) + (eq new-state 'comment) + (eq ?\; (char-before))) + (skip-chars-forward ";") + (paredit-current-parse-state) +;; (parse-partial-sexp (point) (save-excursion +;; (skip-chars-forward ";")) +;; nil nil parse-state) + ) + (t parse-state))) + +(defun paredit-copy-as-kill () + "Save in the kill ring the region that `paredit-kill' would kill." + (interactive) + (cond ((paredit-in-string-p) + (paredit-copy-as-kill-in-string)) + ((paredit-in-comment-p) + (copy-region-as-kill (point) (point-at-eol))) + ((save-excursion (paredit-skip-whitespace t (point-at-eol)) + (or (eolp) (eq (char-after) ?\; ))) + ;** Be careful about trailing backslashes. + (save-excursion + (if (paredit-in-char-p) + (backward-char)) + (copy-region-as-kill (point) (point-at-eol)))) + (t (paredit-copy-sexps-as-kill)))) + +(defun paredit-copy-as-kill-in-string () + (save-excursion + (if (paredit-in-string-escape-p) + (backward-char)) + (copy-region-as-kill (point) + (min (point-at-eol) + (cdr (paredit-string-start+end-points)))))) + +(defun paredit-copy-sexps-as-kill () + (save-excursion + (if (paredit-in-char-p) + (backward-char 2)) + (let ((beginning (point)) + (eol (point-at-eol))) + (let ((end-of-list-p (paredit-forward-sexps-to-kill beginning eol))) + (if end-of-list-p (progn (up-list) (backward-char))) + (copy-region-as-kill beginning + (cond (kill-whole-line + (or (save-excursion + (paredit-skip-whitespace t) + (and (not (eq (char-after) ?\; )) + (point))) + (point-at-eol))) + ((and (not end-of-list-p) + (eq (point-at-eol) eol)) + eol) + (t + (point)))))))) + +;;;; Deleting Regions + +(defun paredit-delete-region (start end) + "Delete the text between point and mark, like `delete-region'. +If that text is unbalanced, signal an error instead. +With a prefix argument, skip the balance check." + (interactive "r") + (if (and start end (not current-prefix-arg)) + (paredit-check-region-for-delete start end)) + (setq this-command 'delete-region) + (delete-region start end)) + +(defun paredit-kill-region (start end) + "Kill the text between point and mark, like `kill-region'. +If that text is unbalanced, signal an error instead. +With a prefix argument, skip the balance check." + (interactive "r") + (if (and start end (not current-prefix-arg)) + (paredit-check-region-for-delete start end)) + (setq this-command 'kill-region) + (kill-region start end)) + +(defun paredit-check-region-for-delete (start end) + "Signal an error deleting text between START and END is unsafe." + (save-excursion + (goto-char start) + (let* ((start-state (paredit-current-parse-state)) + (end-state (parse-partial-sexp start end nil nil start-state))) + (paredit-check-region-for-delete:depth start start-state end end-state) + (paredit-check-region-for-delete:string start start-state end end-state) + (paredit-check-region-for-delete:comment start start-state end end-state) + (paredit-check-region-for-delete:char-quote start start-state + end end-state)))) + +(defun paredit-check-region-for-delete:depth (start start-state end end-state) + (let ((start-depth (nth 0 start-state)) + (end-depth (nth 0 end-state))) + (if (not (= start-depth end-depth)) + (error "Mismatched parenthesis depth: %S at start, %S at end." + start-depth + end-depth)))) + +(defun paredit-check-region-for-delete:string (start start-state end end-state) + (let ((start-string-p (nth 3 start-state)) + (end-string-p (nth 3 end-state))) + (if (not (eq start-string-p end-string-p)) + (error "Mismatched string state: start %sin string, end %sin string." + (if start-string-p "" "not ") + (if end-string-p "" "not "))))) + +(defun paredit-check-region-for-delete:comment + (start start-state end end-state) + (let ((start-comment-state (nth 4 start-state)) + (end-comment-state (nth 4 end-state))) + (if (not (or (eq start-comment-state end-comment-state) + ;; If we are moving text into or out of a line + ;; comment, make sure that the text is balanced. (The + ;; comment state may be a number, not t or nil at all, + ;; for nestable comments, which are not handled by + ;; this heuristic (or any of paredit, really).) + (and (or (and (eq start-comment-state nil) + (eq end-comment-state t)) + (and (eq start-comment-state t) + (eq end-comment-state nil))) + (save-excursion + (goto-char end) + (paredit-region-ok-p (point) (point-at-eol)))))) + (error "Mismatched comment state: %s" + (cond ((and (integerp start-comment-state) + (integerp end-comment-state)) + (format "depth %S at start, depth %S at end." + start-comment-state + end-comment-state)) + ((integerp start-comment-state) + "start in nested comment, end otherwise.") + ((integerp end-comment-state) + "end in nested comment, start otherwise.") + (start-comment-state + "start in comment, end not in comment.") + (end-comment-state + "end in comment, start not in comment.") + (t + (format "start %S, end %S." + start-comment-state + end-comment-state))))))) + +(defun paredit-check-region-for-delete:char-quote + (start start-state end end-state) + (let ((start-char-quote (nth 5 start-state)) + (end-char-quote (nth 5 end-state))) + (if (not (eq start-char-quote end-char-quote)) + (let ((phrase "character quotation")) + (error "Mismatched %s: start %sin %s, end %sin %s." + phrase + (if start-char-quote "" "not ") + phrase + (if end-char-quote "" "not ") + phrase))))) + +;;;; Point Motion + +(eval-and-compile + (defmacro defun-motion (name bvl doc &rest body) + `(defun ,name ,bvl + ,doc + ,(xcond ((paredit-xemacs-p) + '(interactive "_")) + ((paredit-gnu-emacs-p) + ;++ Not sure this is sufficient for the `^'. + (if (fboundp 'handle-shift-selection) + '(interactive "^p") + '(interactive "p")))) + ,@body))) + +(defun-motion paredit-forward (&optional arg) + "Move forward an S-expression, or up an S-expression forward. +If there are no more S-expressions in this one before the closing + delimiter, move past that closing delimiter; otherwise, move forward + past the S-expression following the point." + (let ((n (or arg 1))) + (cond ((< 0 n) (dotimes (i n) (paredit-move-forward))) + ((< n 0) (dotimes (i (- n)) (paredit-move-backward)))))) + +(defun-motion paredit-backward (&optional arg) + "Move backward an S-expression, or up an S-expression backward. +If there are no more S-expressions in this one before the opening + delimiter, move past that opening delimiter backward; otherwise, move + move backward past the S-expression preceding the point." + (let ((n (or arg 1))) + (cond ((< 0 n) (dotimes (i n) (paredit-move-backward))) + ((< n 0) (dotimes (i (- n)) (paredit-move-forward)))))) + +(defun paredit-move-forward () + (cond ((paredit-in-string-p) + (let ((end (paredit-enclosing-string-end))) + ;; `forward-sexp' and `up-list' may move into the next string + ;; in the buffer. Don't do that; move out of the current one. + (if (paredit-handle-sexp-errors + (progn (paredit-handle-sexp-errors (forward-sexp) + (up-list)) + (<= end (point))) + t) + (goto-char end)))) + ((paredit-in-char-p) + (forward-char)) + (t + (paredit-handle-sexp-errors (forward-sexp) + (up-list))))) + +(defun paredit-move-backward () + (cond ((paredit-in-string-p) + (let ((start (paredit-enclosing-string-start))) + (if (paredit-handle-sexp-errors + (progn (paredit-handle-sexp-errors (backward-sexp) + (backward-up-list)) + (<= (point) start)) + t) + (goto-char start)))) + ((paredit-in-char-p) + ;++ Corner case: a buffer of `\|x'. What to do? + (backward-char 2)) + (t + (paredit-handle-sexp-errors (backward-sexp) + (backward-up-list))))) + +;;;; Window Positioning + +(defalias 'paredit-recentre-on-sexp 'paredit-recenter-on-sexp) + +(defun paredit-recenter-on-sexp (&optional n) + "Recenter the screen on the S-expression following the point. +With a prefix argument N, encompass all N S-expressions forward." + (interactive "P") + (let* ((p (point)) + (end-point (progn (forward-sexp n) (point))) + (start-point (progn (goto-char end-point) (backward-sexp n) (point)))) + ;; Point is at beginning of first S-expression. + (let ((p-visible nil) (start-visible nil)) + (save-excursion + (forward-line (/ (count-lines start-point end-point) 2)) + (recenter) + (setq p-visible (pos-visible-in-window-p p)) + (setq start-visible (pos-visible-in-window-p start-point))) + (cond ((not start-visible) + ;; Implies (not p-visible). Put the start at the top of + ;; the screen. + (recenter 0)) + (p-visible + ;; Go back to p if we can. + (goto-char p)))))) + +(defun paredit-recenter-on-defun () + "Recenter the screen on the definition at point." + (interactive) + (save-excursion + (beginning-of-defun) + (paredit-recenter-on-sexp))) + +(defun paredit-focus-on-defun () + "Moves display to the top of the definition at point." + (interactive) + (beginning-of-defun) + (recenter 0)) + +;;;; Generalized Upward/Downward Motion + +(defun paredit-up/down (n vertical-direction) + (let ((horizontal-direction (if (< 0 n) +1 -1))) + (while (/= n 0) + (goto-char + (paredit-next-up/down-point horizontal-direction vertical-direction)) + (setq n (- n horizontal-direction))))) + +(defun paredit-next-up/down-point (horizontal-direction vertical-direction) + (let ((state (paredit-current-parse-state)) + (scan-lists + (lambda () + (scan-lists (point) horizontal-direction vertical-direction)))) + (cond ((paredit-in-string-p state) + (let ((start+end (paredit-string-start+end-points state))) + (if (< 0 vertical-direction) + (if (< 0 horizontal-direction) + (+ 1 (cdr start+end)) + (car start+end)) + ;; We could let the user try to descend into lists + ;; within the string, but that would be asymmetric + ;; with the up case, which rises out of the whole + ;; string and not just out of a list within the + ;; string, so this case will just be an error. + (error "Can't descend further into string.")))) + ((< 0 vertical-direction) + ;; When moving up, just try to rise up out of the list. + (or (funcall scan-lists) + (buffer-end horizontal-direction))) + ((< vertical-direction 0) + ;; When moving down, look for a string closer than a list, + ;; and use that if we find it. + (let* ((list-start + (paredit-handle-sexp-errors (funcall scan-lists) nil)) + (string-start + (paredit-find-next-string-start horizontal-direction + list-start))) + (if (and string-start list-start) + (if (< 0 horizontal-direction) + (min string-start list-start) + (max string-start list-start)) + (or string-start + ;; Scan again: this is a kludgey way to report the + ;; error if there really was one. + (funcall scan-lists) + (buffer-end horizontal-direction))))) + (t + (error "Vertical direction must be nonzero in `%s'." + 'paredit-up/down))))) + +(defun paredit-find-next-string-start (horizontal-direction limit) + (let ((buffer-limit-p (if (< 0 horizontal-direction) 'eobp 'bobp)) + (next-char (if (< 0 horizontal-direction) 'char-after 'char-before)) + (pastp (if (< 0 horizontal-direction) '> '<))) + (paredit-handle-sexp-errors + (save-excursion + (catch 'exit + (while t + (if (or (funcall buffer-limit-p) + (and limit (funcall pastp (point) limit))) + (throw 'exit nil)) + (forward-sexp horizontal-direction) + (save-excursion + (backward-sexp horizontal-direction) + (if (eq ?\" (char-syntax (funcall next-char))) + (throw 'exit (+ (point) horizontal-direction))))))) + nil))) + +(defun-motion paredit-forward-down (&optional argument) + "Move forward down into a list. +With a positive argument, move forward down that many levels. +With a negative argument, move backward down that many levels." + (paredit-up/down (or argument +1) -1)) + +(defun-motion paredit-backward-up (&optional argument) + "Move backward up out of the enclosing list. +With a positive argument, move backward up that many levels. +With a negative argument, move forward up that many levels. +If in a string initially, that counts as one level." + (paredit-up/down (- 0 (or argument +1)) +1)) + +(defun-motion paredit-forward-up (&optional argument) + "Move forward up out of the enclosing list. +With a positive argument, move forward up that many levels. +With a negative argument, move backward up that many levels. +If in a string initially, that counts as one level." + (paredit-up/down (or argument +1) +1)) + +(defun-motion paredit-backward-down (&optional argument) + "Move backward down into a list. +With a positive argument, move backward down that many levels. +With a negative argument, move forward down that many levels." + (paredit-up/down (- 0 (or argument +1)) -1)) + +;;;; Depth-Changing Commands: Wrapping, Splicing, & Raising + +(defun paredit-wrap-sexp (&optional argument open close) + "Wrap the following S-expression. +If a `C-u' prefix argument is given, wrap all S-expressions following + the point until the end of the buffer or of the enclosing list. +If a numeric prefix argument N is given, wrap N S-expressions. +Automatically indent the newly wrapped S-expression. +As a special case, if the point is at the end of a list, simply insert + a parenthesis pair, rather than inserting a lone opening delimiter + and then signalling an error, in the interest of preserving + structure. +By default OPEN and CLOSE are round delimiters." + (interactive "P") + (paredit-lose-if-not-in-sexp 'paredit-wrap-sexp) + (let ((open (or open ?\( )) + (close (or close ?\) ))) + (paredit-handle-sexp-errors + ((lambda (n) (paredit-insert-pair n open close 'goto-char)) + (cond ((integerp argument) argument) + ((consp argument) (paredit-count-sexps-forward)) + ((paredit-region-active-p) nil) + (t 1))) + (insert close) + (backward-char))) + (save-excursion (backward-up-list) (indent-sexp))) + +(defun paredit-yank-pop (&optional argument) + "Replace just-yanked text with the next item in the kill ring. +If this command follows a `yank', just run `yank-pop'. +If this command follows a `paredit-wrap-sexp', or any other paredit + wrapping command (see `paredit-wrap-commands'), run `yank' and + reindent the enclosing S-expression. +If this command is repeated, run `yank-pop' and reindent the enclosing + S-expression. + +The argument is passed on to `yank' or `yank-pop'; see their + documentation for details." + (interactive "*p") + (cond ((eq last-command 'yank) + (yank-pop argument)) + ((memq last-command paredit-wrap-commands) + (yank argument) + ;; `yank' futzes with `this-command'. + (setq this-command 'paredit-yank-pop) + (save-excursion (backward-up-list) (indent-sexp))) + ((eq last-command 'paredit-yank-pop) + ;; Pretend we just did a `yank', so that we can use + ;; `yank-pop' without duplicating its definition. + (setq last-command 'yank) + (yank-pop argument) + ;; Return to our original state. + (setq last-command 'paredit-yank-pop) + (setq this-command 'paredit-yank-pop) + (save-excursion (backward-up-list) (indent-sexp))) + (t (error "Last command was not a yank or a wrap: %s" last-command)))) + +(defun paredit-splice-sexp (&optional argument) + "Splice the list that the point is on by removing its delimiters. +With a prefix argument as in `C-u', kill all S-expressions backward in + the current list before splicing all S-expressions forward into the + enclosing list. +With two prefix arguments as in `C-u C-u', kill all S-expressions + forward in the current list before splicing all S-expressions + backward into the enclosing list. +With a numerical prefix argument N, kill N S-expressions backward in + the current list before splicing the remaining S-expressions into the + enclosing list. If N is negative, kill forward. +Inside a string, unescape all backslashes, or signal an error if doing + so would invalidate the buffer's structure." + (interactive "P") + (if (paredit-in-string-p) + (paredit-splice-string argument) + (if (paredit-in-comment-p) + (error "Can't splice comment.")) + (paredit-handle-sexp-errors (paredit-enclosing-list-start) + (error "Can't splice top level.")) + (paredit-kill-surrounding-sexps-for-splice argument) + (let ((delete-start (paredit-enclosing-list-start)) + (delete-end + (let ((limit + (save-excursion + (paredit-ignore-sexp-errors (forward-sexp) (backward-sexp)) + (point)))) + (save-excursion + (backward-up-list) + (forward-char +1) + (paredit-skip-whitespace t limit) + (point))))) + (let ((end-marker (make-marker))) + (save-excursion + (up-list) + (delete-char -1) + (set-marker end-marker (point))) + (delete-region delete-start delete-end) + (paredit-splice-reindent delete-start (marker-position end-marker)))))) + +(defun paredit-splice-reindent (start end) + (paredit-preserving-column + ;; If we changed the first subform of the enclosing list, we must + ;; reindent the whole enclosing list. + (if (paredit-handle-sexp-errors + (save-excursion + (backward-up-list) + (down-list) + (paredit-ignore-sexp-errors (forward-sexp)) + (< start (point))) + nil) + (save-excursion (backward-up-list) (indent-sexp)) + (paredit-indent-region start end)))) + +(defun paredit-kill-surrounding-sexps-for-splice (argument) + (cond ((or (paredit-in-string-p) + (paredit-in-comment-p)) + (error "Invalid context for splicing S-expressions.")) + ((or (not argument) (eq argument 0)) nil) + ((or (numberp argument) (eq argument '-)) + ;; Kill S-expressions before/after the point by saving the + ;; point, moving across them, and killing the region. + (let* ((argument (if (eq argument '-) -1 argument)) + (saved (paredit-point-at-sexp-boundary (- argument)))) + (goto-char saved) + (paredit-ignore-sexp-errors (backward-sexp argument)) + (paredit-hack-kill-region saved (point)))) + ((consp argument) + (let ((v (car argument))) + (if (= v 4) ;One `C-u'. + ;; Move backward until we hit the open paren; then + ;; kill that selected region. + (let ((end (point))) + (paredit-ignore-sexp-errors + (while (not (bobp)) + (backward-sexp))) + (paredit-hack-kill-region (point) end)) + ;; Move forward until we hit the close paren; then + ;; kill that selected region. + (let ((beginning (point))) + (paredit-ignore-sexp-errors + (while (not (eobp)) + (forward-sexp))) + (paredit-hack-kill-region beginning (point)))))) + (t (error "Bizarre prefix argument `%s'." argument)))) + +(defun paredit-splice-sexp-killing-backward (&optional n) + "Splice the list the point is on by removing its delimiters, and + also kill all S-expressions before the point in the current list. +With a prefix argument N, kill only the preceding N S-expressions." + (interactive "P") + (paredit-splice-sexp (if n + (prefix-numeric-value n) + '(4)))) + +(defun paredit-splice-sexp-killing-forward (&optional n) + "Splice the list the point is on by removing its delimiters, and + also kill all S-expressions after the point in the current list. +With a prefix argument N, kill only the following N S-expressions." + (interactive "P") + (paredit-splice-sexp (if n + (- (prefix-numeric-value n)) + '(16)))) + +(defun paredit-raise-sexp (&optional argument) + "Raise the following S-expression in a tree, deleting its siblings. +With a prefix argument N, raise the following N S-expressions. If N + is negative, raise the preceding N S-expressions. +If the point is on an S-expression, such as a string or a symbol, not + between them, that S-expression is considered to follow the point." + (interactive "P") + (save-excursion + ;; Select the S-expressions we want to raise in a buffer substring. + (let* ((bound + (if (and (not argument) (paredit-region-active-p)) + (progn (if (< (mark) (point)) + (paredit-check-region (mark) (point)) + (paredit-check-region (point) (mark))) + (mark)) + (cond ((paredit-in-string-p) + (goto-char (car (paredit-string-start+end-points)))) + ((paredit-in-char-p) + (backward-sexp)) + ((paredit-in-comment-p) + (error "No S-expression to raise in comment."))) + (scan-sexps (point) (prefix-numeric-value argument)))) + (sexps + (if (< bound (point)) + (buffer-substring bound (paredit-point-at-sexp-end)) + (buffer-substring (paredit-point-at-sexp-start) bound)))) + ;; Move up to the list we're raising those S-expressions out of and + ;; delete it. + (backward-up-list) + (delete-region (point) (scan-sexps (point) 1)) + (let* ((indent-start (point)) + (indent-end (save-excursion (insert sexps) (point)))) + ;; If the expression spans multiple lines, its indentation is + ;; probably broken, so reindent it -- but don't reindent + ;; anything that we didn't touch outside the expression. + ;; + ;; XXX What if the *column* of the starting point was preserved + ;; too? Should we avoid reindenting in that case? + (if (not (eq (save-excursion (goto-char indent-start) (point-at-eol)) + (save-excursion (goto-char indent-end) (point-at-eol)))) + (indent-region indent-start indent-end nil)))))) + +;;; The effects of convolution on the surrounding whitespace are pretty +;;; random. If you have better suggestions, please let me know. + +(defun paredit-convolute-sexp (&optional n) + "Convolute S-expressions. +Save the S-expressions preceding point and delete them. +Splice the S-expressions following point. +Wrap the enclosing list in a new list prefixed by the saved text. +With a prefix argument N, move up N lists before wrapping." + (interactive "p") + (paredit-lose-if-not-in-sexp 'paredit-convolute-sexp) + ;; Make sure we can move up before destroying anything. + (save-excursion (backward-up-list n) (backward-up-list)) + (let (open close) ;++ Is this a good idea? + (let ((prefix + (let ((end (point))) + (paredit-ignore-sexp-errors + (while (not (bobp)) (backward-sexp))) + (prog1 (buffer-substring (point) end) + (backward-up-list) + (save-excursion (forward-sexp) + (setq close (char-before)) + (delete-char -1)) + (setq open (char-after)) + (delete-region (point) end) + ;; I'm not sure this makes sense... + (if (not (eolp)) (just-one-space)))))) + (backward-up-list n) + (paredit-insert-pair 1 open close 'goto-char) + (insert prefix) + ;; I'm not sure this makes sense either... + (if (not (eolp)) (just-one-space)) + (save-excursion + (backward-up-list) + (paredit-ignore-sexp-errors (indent-sexp)))))) + +(defun paredit-splice-string (argument) + (let ((original-point (point)) + (start+end (paredit-string-start+end-points))) + (let ((start (car start+end)) + (end (cdr start+end))) + ;; START and END both lie before the respective quote + ;; characters, which we want to delete; thus we increment START + ;; by one to extract the string, and we increment END by one to + ;; delete the string. + (let* ((escaped-string + (cond ((not (consp argument)) + (buffer-substring (1+ start) end)) + ((= 4 (car argument)) + (buffer-substring original-point end)) + (t + (buffer-substring (1+ start) original-point)))) + (unescaped-string + (paredit-unescape-string escaped-string))) + (if (not unescaped-string) + (error "Unspliceable string.") + (save-excursion + (goto-char start) + (delete-region start (1+ end)) + (insert unescaped-string)) + (if (not (and (consp argument) + (= 4 (car argument)))) + (goto-char (- original-point 1)))))))) + +(defun paredit-unescape-string (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (and (not (eobp)) + ;; nil -> no bound; t -> no errors. + (search-forward "\\" nil t)) + (delete-char -1) + (forward-char)) + (paredit-handle-sexp-errors + (progn (scan-sexps (point-min) (point-max)) + (buffer-string)) + nil))) + +;;;; Slurpage & Barfage + +(defun paredit-forward-slurp-sexp (&optional argument) + "Add the S-expression following the current list into that list + by moving the closing delimiter. +Automatically reindent the newly slurped S-expression with respect to + its new enclosing form. +If in a string, move the opening double-quote forward by one + S-expression and escape any intervening characters as necessary, + without altering any indentation or formatting." + (interactive "P") + (save-excursion + (cond ((paredit-in-comment-p) + (error "Invalid context for slurping S-expressions.")) + ((numberp argument) + (if (< argument 0) + (paredit-forward-barf-sexp (- 0 argument)) + (while (< 0 argument) + (paredit-forward-slurp-sexp) + (setq argument (- argument 1))))) + ((paredit-in-string-p) + ;; If there is anything to slurp into the string, take that. + ;; Otherwise, try to slurp into the enclosing list. + (if (save-excursion + (goto-char (paredit-enclosing-string-end)) + (paredit-handle-sexp-errors (progn (forward-sexp) nil) + t)) + (progn + (goto-char (paredit-enclosing-string-end)) + (paredit-forward-slurp-into-list argument)) + (paredit-forward-slurp-into-string argument))) + (t + (paredit-forward-slurp-into-list argument))))) + +(defun paredit-forward-slurp-into-list (&optional argument) + (let ((nestedp nil)) + (save-excursion + (up-list) ; Up to the end of the list to + (let ((close (char-before))) ; save and delete the closing + (delete-char -1) ; delimiter. + (let ((start (point))) + (catch 'return ; Go to the end of the desired + (while t ; S-expression, going up a + (paredit-handle-sexp-errors ; list if it's not in this, + (progn (forward-sexp) + (if argument + (paredit-ignore-sexp-errors + (while (not (eobp)) + (forward-sexp)))) + (throw 'return nil)) + (setq nestedp t) + (up-list) + (setq close ; adjusting for mixed + (prog1 (char-before) ; delimiters as necessary, + (delete-char -1) + (insert close)))))) + (insert close) ; to insert that delimiter. + (indent-region start (point) nil)))) + (if (and (not nestedp) + (eq (save-excursion (paredit-skip-whitespace nil) (point)) + (save-excursion (backward-up-list) (forward-char) (point))) + (eq (save-excursion (forward-sexp) (backward-sexp) (point)) + (save-excursion (paredit-skip-whitespace t) (point)))) + (delete-region (save-excursion (paredit-skip-whitespace nil) (point)) + (save-excursion (paredit-skip-whitespace t) (point)))))) + +(defun paredit-forward-slurp-into-string (&optional argument) + (let ((start (paredit-enclosing-string-start)) + (end (paredit-enclosing-string-end))) + (goto-char end) + ;; Signal any errors that we might get first, before mucking with + ;; the buffer's contents. + (save-excursion (forward-sexp)) + (let ((close (char-before))) + ;; Skip intervening whitespace if we're slurping into an empty + ;; string. XXX What about nonempty strings? + (if (and (= (+ start 2) end) + (eq (save-excursion (paredit-skip-whitespace t) (point)) + (save-excursion (forward-sexp) (backward-sexp) (point)))) + (delete-region (- (point) 1) + (save-excursion (paredit-skip-whitespace t) (point))) + (delete-char -1)) + (paredit-forward-for-quote + (save-excursion + (forward-sexp) + (if argument + (while (paredit-handle-sexp-errors (progn (forward-sexp) t) nil))) + (point))) + (insert close)))) + +(defun paredit-forward-barf-sexp (&optional argument) + "Remove the last S-expression in the current list from that list + by moving the closing delimiter. +Automatically reindent the newly barfed S-expression with respect to + its new enclosing form." + (interactive "P") + (paredit-lose-if-not-in-sexp 'paredit-forward-barf-sexp) + (if (and (numberp argument) (< argument 0)) + (paredit-forward-slurp-sexp (- 0 argument)) + (let ((start (point)) (end nil)) + (save-excursion + (up-list) ; Up to the end of the list to + (let ((close (char-before))) ; save and delete the closing + (delete-char -1) ; delimiter. + (setq end (point)) + (paredit-ignore-sexp-errors ; Go back to where we want to + (if (or (not argument) ; insert the delimiter. + (numberp argument)) + (backward-sexp argument) + (while (paredit-handle-sexp-errors + (save-excursion (backward-sexp) (<= start (point))) + nil) + (backward-sexp)))) + (paredit-skip-whitespace nil) ; Skip leading whitespace. + (cond ((bobp) + ;++ We'll have deleted the close, but there's no open. + ;++ Is that OK? + (error "Barfing all subexpressions with no open-paren?")) + ((paredit-in-comment-p) ; Don't put the close-paren in + (newline))) ; a comment. + (insert close)) + ;; Reindent all of the newly barfed S-expressions. Start at the + ;; start of the first barfed S-expression, not at the close we + ;; just inserted. + (forward-sexp) + (backward-sexp) + (if (or (not argument) (numberp argument)) + (paredit-forward-and-indent argument) + (indent-region (point) end)))))) + +(defun paredit-backward-slurp-sexp (&optional argument) + "Add the S-expression preceding the current list into that list + by moving the closing delimiter. +Automatically reindent the whole form into which new S-expression was + slurped. +If in a string, move the opening double-quote backward by one + S-expression and escape any intervening characters as necessary, + without altering any indentation or formatting." + (interactive "P") + (save-excursion + (cond ((paredit-in-comment-p) + (error "Invalid context for slurping S-expressions.")) + ((numberp argument) + (if (< argument 0) + (paredit-backward-barf-sexp (- 0 argument)) + (while (< 0 argument) + (paredit-backward-slurp-sexp) + (setq argument (- argument 1))))) + ((paredit-in-string-p) + ;; If there is anything to slurp into the string, take that. + ;; Otherwise, try to slurp into the enclosing list. + (if (save-excursion + (goto-char (paredit-enclosing-string-start)) + (paredit-handle-sexp-errors (progn (backward-sexp) nil) + t)) + (progn + (goto-char (paredit-enclosing-string-start)) + (paredit-backward-slurp-into-list argument)) + (paredit-backward-slurp-into-string argument))) + (t + (paredit-backward-slurp-into-list argument))))) + +(defun paredit-backward-slurp-into-list (&optional argument) + (let ((nestedp nil)) + (save-excursion + (backward-up-list) + (let ((open (char-after))) + (delete-char +1) + (catch 'return + (while t + (paredit-handle-sexp-errors + (progn (backward-sexp) + (if argument + (paredit-ignore-sexp-errors + (while (not (bobp)) + (backward-sexp)))) + (throw 'return nil)) + (setq nestedp t) + (backward-up-list) + (setq open + (prog1 (char-after) + (save-excursion (insert open) (delete-char +1))))))) + (insert open)) + ;; Reindent the line at the beginning of wherever we inserted the + ;; opening delimiter, and then indent the whole S-expression. + (backward-up-list) + (lisp-indent-line) + (indent-sexp)) + ;; If we slurped into an empty list, don't leave dangling space: + ;; (foo |). + (if (and (not nestedp) + (eq (save-excursion (paredit-skip-whitespace nil) (point)) + (save-excursion (backward-sexp) (forward-sexp) (point))) + (eq (save-excursion (up-list) (backward-char) (point)) + (save-excursion (paredit-skip-whitespace t) (point)))) + (delete-region (save-excursion (paredit-skip-whitespace nil) (point)) + (save-excursion (paredit-skip-whitespace t) (point)))))) + +(defun paredit-backward-slurp-into-string (&optional argument) + (let ((start (paredit-enclosing-string-start)) + (end (paredit-enclosing-string-end))) + (goto-char start) + ;; Signal any errors that we might get first, before mucking with + ;; the buffer's contents. + (save-excursion (backward-sexp)) + (let ((open (char-after)) + (target (point))) + ;; Skip intervening whitespace if we're slurping into an empty + ;; string. XXX What about nonempty strings? + (if (and (= (+ start 2) end) + (eq (save-excursion (paredit-skip-whitespace nil) (point)) + (save-excursion (backward-sexp) (forward-sexp) (point)))) + (delete-region (save-excursion (paredit-skip-whitespace nil) (point)) + (+ (point) 1)) + (delete-char +1)) + (backward-sexp) + (if argument + (paredit-ignore-sexp-errors + (while (not (bobp)) + (backward-sexp)))) + (insert open) + (paredit-forward-for-quote target)))) + +(defun paredit-backward-barf-sexp (&optional argument) + "Remove the first S-expression in the current list from that list + by moving the closing delimiter. +Automatically reindent the barfed S-expression and the form from which + it was barfed." + (interactive "P") + (paredit-lose-if-not-in-sexp 'paredit-backward-barf-sexp) + (if (and (numberp argument) (< argument 0)) + (paredit-backward-slurp-sexp (- 0 argument)) + (let ((end (make-marker))) + (set-marker end (point)) + (save-excursion + (backward-up-list) + (let ((open (char-after))) + (delete-char +1) + (paredit-ignore-sexp-errors + (paredit-forward-and-indent + (if (or (not argument) (numberp argument)) + argument + (let ((n 0)) + (save-excursion + (while (paredit-handle-sexp-errors + (save-excursion + (forward-sexp) + (<= (point) end)) + nil) + (forward-sexp) + (setq n (+ n 1)))) + n)))) + (while (progn (paredit-skip-whitespace t) (eq (char-after) ?\; )) + (forward-line 1)) + (if (eobp) + ;++ We'll have deleted the close, but there's no open. + ;++ Is that OK? + (error "Barfing all subexpressions with no close-paren?")) + ;** Don't use `insert' here. Consider, e.g., barfing from + ;** (foo|) + ;** and how `save-excursion' works. + (insert-before-markers open)) + (backward-up-list) + (lisp-indent-line) + (indent-sexp))))) + +;;;; Splitting & Joining + +(defun paredit-split-sexp () + "Split the list or string the point is on into two." + (interactive) + (cond ((paredit-in-string-p) + (insert "\"") + (save-excursion (insert " \""))) + ((or (paredit-in-comment-p) + (paredit-in-char-p)) + (error "Invalid context for splitting S-expression.")) + (t + (let ((open (save-excursion (backward-up-list) (char-after))) + (close (save-excursion (up-list) (char-before)))) + (delete-horizontal-space) + (insert close) + (save-excursion + (insert ?\ ) + (insert open) + (backward-char) + (indent-sexp)))))) + +(defun paredit-join-sexps () + "Join the S-expressions adjacent on either side of the point. +Both must be lists, strings, or atoms; error if there is a mismatch." + (interactive) + (cond ((paredit-in-comment-p) (error "Can't join S-expressions in comment.")) + ((paredit-in-string-p) (error "Nothing to join in a string.")) + ((paredit-in-char-p) (error "Can't join characters."))) + (let ((left-point (paredit-point-at-sexp-end)) + (right-point (paredit-point-at-sexp-start))) + (let ((left-char (char-before left-point)) + (right-char (char-after right-point))) + (let ((left-syntax (char-syntax left-char)) + (right-syntax (char-syntax right-char))) + (cond ((< right-point left-point) + (error "Can't join a datum with itself.")) + ((and (eq left-syntax ?\) ) + (eq right-syntax ?\( ) + (eq left-char (matching-paren right-char)) + (eq right-char (matching-paren left-char))) + (paredit-join-lists-internal left-point right-point) + (paredit-preserving-column + (save-excursion + (backward-up-list) + (indent-sexp)))) + ((and (eq left-syntax ?\" ) + (eq right-syntax ?\" )) + ;; Delete any intermediate formatting. + (delete-region (1- left-point) (1+ right-point))) + ((and (memq left-syntax '(?w ?_)) ; Word or symbol + (memq right-syntax '(?w ?_))) + (delete-region left-point right-point)) + (t (error "Mismatched S-expressions to join."))))))) + +(defun paredit-join-lists-internal (left-point right-point) + (save-excursion + ;; Leave intermediate formatting alone. + (goto-char right-point) + (delete-char +1) + (goto-char left-point) + (delete-char -1) + ;; Kludge: Add an extra space in several conditions. + (if (or + ;; (foo)| ;x\n(bar) => (foo | ;x\nbar), not (foo| ;x\nbar). + (and (not (eolp)) + (save-excursion + (paredit-skip-whitespace t (point-at-eol)) + (eq (char-after) ?\;))) + ;; (foo)|(bar) => (foo| bar), not (foo|bar). + (and (= left-point right-point) + (not (or (eq ?\ (char-syntax (char-before))) + (eq ?\ (char-syntax (char-after))))))) + (insert ?\ )))) + +;++ How ought paredit-join to handle comments intervening symbols or strings? +;++ Idea: +;++ +;++ "foo" | ;bar +;++ "baz" ;quux +;++ +;++ => +;++ +;++ "foo|baz" ;bar +;++ ;quux +;++ +;++ The point should stay where it is relative to the comments, and the +;++ the comments' columns should all be preserved, perhaps. Hmmmm... +;++ What about this? +;++ +;++ "foo" ;bar +;++ | ;baz +;++ "quux" ;zot + +;++ Should rename: +;++ paredit-point-at-sexp-start -> paredit-start-of-sexp-after-point +;++ paredit-point-at-sexp-end -> paredit-end-of-sexp-before-point + +;;;; Variations on the Lurid Theme + +;;; I haven't the imagination to concoct clever names for these. + +(defun paredit-add-to-previous-list () + "Add the S-expression following point to the list preceding point." + (interactive) + (paredit-lose-if-not-in-sexp 'paredit-add-to-previous-list) + (save-excursion + (down-list -1) ;++ backward-down-list... + (paredit-forward-slurp-sexp))) + +(defun paredit-add-to-next-list () + "Add the S-expression preceding point to the list following point. +If no S-expression precedes point, move up the tree until one does." + (interactive) + (paredit-lose-if-not-in-sexp 'paredit-add-to-next-list) + (save-excursion + (down-list) + (paredit-backward-slurp-sexp))) + +(defun paredit-join-with-previous-list () + "Join the list the point is on with the previous list in the buffer." + (interactive) + (paredit-lose-if-not-in-sexp 'paredit-join-with-previous-list) + (save-excursion + (while (paredit-handle-sexp-errors (save-excursion (backward-sexp) nil) + (backward-up-list) + t)) + (paredit-join-sexps))) + +(defun paredit-join-with-next-list () + "Join the list the point is on with the next list in the buffer." + (interactive) + (paredit-lose-if-not-in-sexp 'paredit-join-with-next-list) + (save-excursion + (while (paredit-handle-sexp-errors (save-excursion (forward-sexp) nil) + (up-list) + t)) + (paredit-join-sexps))) + +;;;; Utilities + +(defun paredit-in-string-escape-p () + "True if the point is on a character escape of a string. +This is true only if the character is preceded by an odd number of + backslashes. +This assumes that `paredit-in-string-p' has already returned true." + (let ((oddp nil)) + (save-excursion + (while (eq (char-before) ?\\ ) + (setq oddp (not oddp)) + (backward-char))) + oddp)) + +(defun paredit-in-char-p (&optional position) + "True if point is on a character escape outside a string." + (save-excursion + (goto-char (or position (point))) + (paredit-in-string-escape-p))) + +(defun paredit-skip-whitespace (trailing-p &optional limit) + "Skip past any whitespace, or until the point LIMIT is reached. +If TRAILING-P is nil, skip leading whitespace; otherwise, skip trailing + whitespace." + (funcall (if trailing-p 'skip-chars-forward 'skip-chars-backward) + " \t\n " ; This should skip using the syntax table, but LF + limit)) ; is a comment end, not newline, in Lisp mode. + +(defalias 'paredit-region-active-p + (xcond ((paredit-xemacs-p) 'region-active-p) + ((paredit-gnu-emacs-p) + (lambda () + (and mark-active transient-mark-mode))))) + +(defun paredit-hack-kill-region (start end) + "Kill the region between START and END. +Do not append to any current kill, and + do not let the next kill append to this one." + (interactive "r") ;Eh, why not? + ;; KILL-REGION sets THIS-COMMAND to tell the next kill that the last + ;; command was a kill. It also checks LAST-COMMAND to see whether it + ;; should append. If we bind these locally, any modifications to + ;; THIS-COMMAND will be masked, and it will not see LAST-COMMAND to + ;; indicate that it should append. + (let ((this-command nil) + (last-command nil)) + (kill-region start end))) + +;;;;; Reindentation utilities + +;++ Should `paredit-indent-sexps' and `paredit-forward-and-indent' use +;++ `paredit-indent-region' rather than `indent-region'? + +(defun paredit-indent-sexps () + "If in a list, indent all following S-expressions in the list." + (let* ((start (point)) + (end (paredit-handle-sexp-errors (progn (up-list) (point)) nil))) + (if end + (indent-region start end nil)))) + +(defun paredit-forward-and-indent (&optional n) + "Move forward by N S-expressions, indenting them with `indent-region'." + (let ((start (point))) + (forward-sexp n) + (indent-region start (point) nil))) + +(defun paredit-indent-region (start end) + "Indent the region from START to END. +Don't reindent the line starting at START, however." + (if (not (<= start end)) + (error "Incorrectly related points: %S, %S" start end)) + (save-excursion + (goto-char start) + (let ((bol (point-at-bol))) + ;; Skip all S-expressions that end on the starting line, but + ;; don't go past `end'. + (if (and (save-excursion (goto-char end) (not (eq bol (point-at-bol)))) + (paredit-handle-sexp-errors + (catch 'exit + (while t + (save-excursion + (forward-sexp) + (if (not (eq bol (point-at-bol))) + (throw 'exit t)) + (if (not (< (point) end)) + (throw 'exit nil))) + (forward-sexp))) + nil)) + (progn + ;; Point is still on the same line, but precedes an + ;; S-expression that ends on a different line. + (if (not (eq bol (point-at-bol))) + (error "Internal error -- we moved forward a line!")) + (goto-char (+ 1 (point-at-eol))) + (if (not (<= (point) end)) + (error "Internal error -- we frobnitzed the garfnut!")) + (indent-region (point) end nil)))))) + +;;;;; S-expression Parsing Utilities + +;++ These routines redundantly traverse S-expressions a great deal. +;++ If performance issues arise, this whole section will probably have +;++ to be refactored to preserve the state longer, like paredit.scm +;++ does, rather than to traverse the definition N times for every key +;++ stroke as it presently does. + +(defun paredit-current-parse-state () + "Return parse state of point from beginning of defun." + (let ((point (point))) + (beginning-of-defun) + ;; Calling PARSE-PARTIAL-SEXP will advance the point to its second + ;; argument (unless parsing stops due to an error, but we assume it + ;; won't in paredit-mode). + (parse-partial-sexp (point) point))) + +(defun paredit-in-string-p (&optional state) + "True if the parse state is within a double-quote-delimited string. +If no parse state is supplied, compute one from the beginning of the + defun to the point." + ;; 3. non-nil if inside a string (the terminator character, really) + (and (nth 3 (or state (paredit-current-parse-state))) + t)) + +(defun paredit-string-start+end-points (&optional state) + "Return a cons of the points of open and close quotes of the string. +The string is determined from the parse state STATE, or the parse state + from the beginning of the defun to the point. +This assumes that `paredit-in-string-p' has already returned true, i.e. + that the point is already within a string." + (save-excursion + ;; 8. character address of start of comment or string; nil if not + ;; in one + (let ((start (nth 8 (or state (paredit-current-parse-state))))) + (goto-char start) + (forward-sexp 1) + (cons start (1- (point)))))) + +(defun paredit-enclosing-string-start () + (car (paredit-string-start+end-points))) + +(defun paredit-enclosing-string-end () + (+ 1 (cdr (paredit-string-start+end-points)))) + +(defun paredit-enclosing-list-start () + (save-excursion + (backward-up-list) + (point))) + +(defun paredit-enclosing-list-end () + (save-excursion + (up-list) + (point))) + +(defun paredit-in-comment-p (&optional state) + "True if parse state STATE is within a comment. +If no parse state is supplied, compute one from the beginning of the + defun to the point." + ;; 4. nil if outside a comment, t if inside a non-nestable comment, + ;; else an integer (the current comment nesting) + (and (nth 4 (or state (paredit-current-parse-state))) + t)) + +(defun paredit-prefix-numeric-value (argument) + ;++ Kludgerific. + (cond ((integerp argument) argument) + ((eq argument '-) -1) + ((consp argument) + (cond ((equal argument '(4)) (paredit-count-sexps-forward)) ;C-u + ((equal argument '(16)) (paredit-count-sexps-backward)) ;C-u C-u + (t (error "Invalid prefix argument: %S" argument)))) + ((paredit-region-active-p) + (save-excursion + (save-restriction + (narrow-to-region (region-beginning) (region-end)) + (cond ((= (point) (point-min)) (paredit-count-sexps-forward)) + ((= (point) (point-max)) (paredit-count-sexps-backward)) + (t + (error "Point %S is not start or end of region: %S..%S" + (point) (region-beginning) (region-end))))))) + (t 1))) + +(defun paredit-count-sexps-forward () + (save-excursion + (let ((n 0) (p nil)) ;hurk + (paredit-ignore-sexp-errors + (while (setq p (scan-sexps (point) +1)) + (goto-char p) + (setq n (+ n 1)))) + n))) + +(defun paredit-count-sexps-backward () + (save-excursion + (let ((n 0) (p nil)) ;hurk + (paredit-ignore-sexp-errors + (while (setq p (scan-sexps (point) -1)) + (goto-char p) + (setq n (+ n 1)))) + n))) + +(defun paredit-point-at-sexp-boundary (n) + (cond ((< n 0) (paredit-point-at-sexp-start)) + ((= n 0) (point)) + ((> n 0) (paredit-point-at-sexp-end)))) + +(defun paredit-point-at-sexp-start () + (save-excursion + (forward-sexp) + (backward-sexp) + (point))) + +(defun paredit-point-at-sexp-end () + (save-excursion + (backward-sexp) + (forward-sexp) + (point))) + +(defun paredit-lose-if-not-in-sexp (command) + (if (or (paredit-in-string-p) + (paredit-in-comment-p) + (paredit-in-char-p)) + (error "Invalid context for command `%s'." command))) + +(defun paredit-check-region (start end) + "Signal an error if text between `start' and `end' is unbalanced." + ;; `narrow-to-region' will move the point, so avoid calling it if we + ;; don't need to. We don't want to use `save-excursion' because we + ;; want the point to move if `check-parens' reports an error. + (if (not (paredit-region-ok-p start end)) + (save-restriction + (narrow-to-region start end) + (check-parens)))) + +(defun paredit-region-ok-p (start end) + "Return true iff the region between `start' and `end' is balanced. +This is independent of context -- it doesn't check what state the + text at `start' is in." + (save-excursion + (paredit-handle-sexp-errors + (progn + (save-restriction + (narrow-to-region start end) + (scan-sexps (point-min) (point-max))) + t) + nil))) + +(defun paredit-current-column () + ;; Like current-column, but respects field boundaries in interactive + ;; modes like ielm. For use only with paredit-restore-column, which + ;; works relative to point-at-bol. + (- (point) (point-at-bol))) + +(defun paredit-current-indentation () + (save-excursion + (back-to-indentation) + (paredit-current-column))) + +(defun paredit-restore-column (column indentation) + ;; Preserve the point's position either in the indentation or in the + ;; code: if on code, move with the code; if in indentation, leave it + ;; in the indentation, either where it was (if still on indentation) + ;; or at the end of the indentation (if the code moved far enough + ;; left). + (let ((indentation* (paredit-current-indentation))) + (goto-char + (+ (point-at-bol) + (cond ((not (< column indentation)) + (+ column (- indentation* indentation))) + ((<= indentation* column) indentation*) + (t column)))))) + +;;;; Initialization + +(paredit-define-keys) +(paredit-annotate-mode-with-examples) +(paredit-annotate-functions-with-examples) + +(provide 'paredit) + +;;; Local Variables: +;;; outline-regexp: " \n;;;;+" +;;; End: + +;;; paredit.el ends here blob - /dev/null blob + 50f6796a1ebf412bda9821ca8cc3bdb833a7022b (mode 644) --- /dev/null +++ elpa/paredit-26.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2024-03-31T13:25:06+0200 using EDDSA \ No newline at end of file blob - /dev/null blob + 3304bb0484f888d102fb74d80bc11cc4ff4b08cf (mode 644) --- /dev/null +++ elpa/paredit-menu-20160128.1733/paredit-menu-autoloads.el @@ -0,0 +1,28 @@ +;;; paredit-menu-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from paredit-menu.el + +(register-definition-prefixes "paredit-menu" '("paredit-menu-")) + +;;; End of scraped data + +(provide 'paredit-menu-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; paredit-menu-autoloads.el ends here blob - /dev/null blob + 5b560e4b2b2f681d277e2017f20ec54be0728020 (mode 644) --- /dev/null +++ elpa/paredit-menu-20160128.1733/paredit-menu-pkg.el @@ -0,0 +1,10 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "paredit-menu" "20160128.1733" + "Adds a menu to paredit.el as memory aid." + '((paredit "25")) + :url "https://github.com/phillord/paredit-menu" + :commit "cc0ae85bd819f9ebfa4f2a419ab3b2d70e39c9c8" + :revdesc "cc0ae85bd819" + :keywords '("paredit") + :authors '(("Phillip Lord" . "phillip.lord@newcastle.ac.uk")) + :maintainers '(("Phillip Lord" . "phillip.lord@newcastle.ac.uk"))) blob - /dev/null blob + 4e3f90b946f8764facf77a46300b550134b3eddc (mode 644) --- /dev/null +++ elpa/paredit-menu-20160128.1733/paredit-menu.el @@ -0,0 +1,126 @@ +;;; paredit-menu.el --- Adds a menu to paredit.el as memory aid + +;; This file is not part of Emacs + +;; Author: Phillip Lord +;; Maintainer: Phillip Lord +;; Keywords: paredit +;; Package-Version: 20160128.1733 +;; Package-Revision: cc0ae85bd819 +;; Package-Requires: ((paredit "25")) + +;; COPYRIGHT NOTICE +;; +;; This program 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 program 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 this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; Paredit mode provides structured editing for Lisp. It achieves this by +;; ensuring that code is always well-formed while editing. While it is very +;; helpful, sometimes it leaves the less experienced user (such as the myself) +;; scratching their head over how to achieve a simple editing task. + +;; One solution is to use the cheatsheet +;; (http://emacswiki.org/emacs/PareditCheatsheet). However, this is outside +;; Emacs and does not scale well. This file provides a second solution, which +;; is a menu. While slower than using the equivalent key-presses, it provides +;; an easy mechanism to look up the relevant commands. Tooltips are also +;; provided showing the examples of use. + +;; Documentation and examples come directly from paredit, so the menu should +;; automatically stay in sync, regardless of changes to paredit. + +;;; Installation: +;; +;; Add (require 'paredit-menu) to your .emacs. This will also force loading of +;; paredit. If you autoload paredit, then +;; +;; (eval-after-load "paredit.el" +;; '(require 'paredit-menu)) +;; +;; will achieve the same effect. + + +(require 'paredit) + +;;; Code: + +(defun paredit-menu-build-menu () + "Builds the menu from `paredit-commands'." + (cons "Paredit" + (paredit-menu-build-menu-1 paredit-commands nil nil))) + +(defun paredit-menu-build-menu-1 (commands menu submenu) + "Really builds the menu. + +COMMANDS is the list of commands remaining to add +MENU is the current menu +SUBMENU is the current submenu" + (let ((first (car commands)) + (rest (cdr commands))) + ;; drop last submenu in place and complete + (if (not first) + (append menu (list submenu)) + ;; is a submenu title + (if (stringp first) + ;; start a new submenu + (paredit-menu-build-menu-1 + rest + ;; appending the last submenu if it exists + (if submenu + (append menu (list submenu)) + menu) + (list first)) + ;; we have a command + (paredit-menu-build-menu-1 + rest menu + (append submenu + (list (vector (paredit-menu-symbol-name + (symbol-name (nth 1 first))) + (nth 1 first) + :help (paredit-menu-help-string first))))))))) + + +(defun paredit-menu-symbol-name (name) + "Generate display name from symbol name. + +No point putting \"paredit\" on the front of everything, so chop +this off. + +NAME is the symbol name." + (substring name 8)) + +(defun paredit-menu-help-string (command) + "Generate help string for command. + +COMMAND is the command" + (let ((string + (mapconcat + (lambda (x) + (format "%s -> \n\t%s" (nth 0 x) (nth 1 x)) + ) + (cddr command) "\n\n"))) + (if (eq "" string) + "No Example" + string))) + + +(easy-menu-define menubar-paredit paredit-mode-map "paredit" + (paredit-menu-build-menu)) + +(provide 'paredit-menu) + +;;; paredit-menu.el ends here blob - /dev/null blob + 02f3c45299431cd2baa03e6e40952bd3dd397ceb (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-autodoc.el @@ -0,0 +1,180 @@ +;;; -*-lexical-binding:t-*- +;;; (require 'sly) +(require 'eldoc) +(require 'cl-lib) +(require 'sly-parse "lib/sly-parse") + +(define-sly-contrib sly-autodoc + "Show fancy arglist in echo area." + (:license "GPL") + (:authors "Luke Gorrie " + "Lawrence Mitchell " + "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:slynk-dependencies slynk/arglists) + (:on-load (add-hook 'sly-editing-mode-hook 'sly-autodoc-mode) + (add-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode) + (add-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode)) + (:on-unload (remove-hook 'sly-editing-mode-hook 'sly-autodoc-mode) + (remove-hook 'sly-mrepl-mode-hook 'sly-autodoc-mode) + (remove-hook 'sly-minibuffer-setup-hook 'sly-autodoc-mode))) + +(defcustom sly-autodoc-accuracy-depth 10 + "Number of paren levels that autodoc takes into account for + context-sensitive arglist display (local functions. etc)" + :type 'integer + :group 'sly-ui) + + + +(defun sly-arglist (name) + "Show the argument list for NAME." + (interactive (list (sly-read-symbol-name "Arglist of: " t))) + (let ((arglist (sly-autodoc--retrieve-arglist name))) + (if (eq arglist :not-available) + (error "Arglist not available") + (message "%s" (sly-autodoc--fontify arglist))))) + +(defun sly-autodoc--retrieve-arglist (name) + (let ((name (cl-etypecase name + (string name) + (symbol (symbol-name name))))) + (car (sly-eval `(slynk:autodoc '(,name ,sly-cursor-marker)))))) + +(defun sly-autodoc-manually () + "Like autodoc information forcing multiline display." + (interactive) + (let ((doc (sly-autodoc t))) + (cond (doc (eldoc-message (format "%s" doc))) + (t (eldoc-message nil))))) + +;; Must call eldoc-add-command otherwise (eldoc-display-message-p) +;; returns nil and eldoc clears the echo area instead. +(eldoc-add-command 'sly-autodoc-manually) + +(defun sly-autodoc-space (n) + "Like `sly-space' but nicer." + (interactive "p") + (self-insert-command n) + (let ((doc (sly-autodoc))) + (when doc + (eldoc-message (format "%s" doc))))) + +(eldoc-add-command 'sly-autodoc-space) + + +;;;; Autodoc cache + +(defvar sly-autodoc--cache-last-context nil) +(defvar sly-autodoc--cache-last-autodoc nil) + + +;;;; Formatting autodoc + +(defsubst sly-autodoc--canonicalize-whitespace (string) + (replace-regexp-in-string "[ \n\t]+" " " string)) + +(defvar sly-autodoc-preamble nil) + +(defun sly-autodoc--format (doc multilinep) + (let* ((strings (delete nil + (list sly-autodoc-preamble + (and doc + (sly-autodoc--fontify doc))))) + (message (and strings (mapconcat #'identity strings "\n")))) + (when message + (cond (multilinep message) + (t (sly-oneliner (sly-autodoc--canonicalize-whitespace message))))))) + +(defun sly-autodoc--fontify (string) + "Fontify STRING as `font-lock-mode' does in Lisp mode." + (with-current-buffer (get-buffer-create (sly-buffer-name :fontify :hidden t)) + (erase-buffer) + (unless (eq major-mode 'lisp-mode) + ;; Just calling (lisp-mode) will turn sly-mode on in that buffer, + ;; which may interfere with this function + (setq major-mode 'lisp-mode) + (lisp-mode-variables t)) + (insert string) + (let ((font-lock-verbose nil)) + (font-lock-fontify-buffer)) + (goto-char (point-min)) + (when (re-search-forward "===> \\(\\(.\\|\n\\)*\\) <===" nil t) + (let ((highlight (match-string 1))) + ;; Can't use (replace-match highlight) here -- broken in Emacs 21 + (delete-region (match-beginning 0) (match-end 0)) + (sly-insert-propertized '(face eldoc-highlight-function-argument) + highlight))) + (buffer-substring (point-min) (point-max)))) + + +;;;; Autodocs (automatic context-sensitive help) + +(defun sly-autodoc (&optional force-multiline) + "Returns the cached arglist information as string, or nil. +If it's not in the cache, the cache will be updated asynchronously." + (interactive "P") + (save-excursion + (save-match-data + ;; See github#385 and + ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45117 + (let* ((inhibit-quit t) + (context + (cons + (sly-current-connection) + (sly-autodoc--parse-context)))) + (when (car context) + (let* ((cached (and (equal context sly-autodoc--cache-last-context) + sly-autodoc--cache-last-autodoc)) + (multilinep (or force-multiline + eldoc-echo-area-use-multiline-p))) + (cond (cached (sly-autodoc--format cached multilinep)) + (t + (when (sly-background-activities-enabled-p) + (sly-autodoc--async context multilinep)) + nil)))))))) + +;; Return the context around point that can be passed to +;; slynk:autodoc. nil is returned if nothing reasonable could be +;; found. +(defun sly-autodoc--parse-context () + (and (not (sly-inside-string-or-comment-p)) + (sly-parse-form-upto-point sly-autodoc-accuracy-depth))) + +(defun sly-autodoc--async (context multilinep) + (sly-eval-async + `(slynk:autodoc ',(cdr context) ;; FIXME: misuse of quote + :print-right-margin ,(window-width (minibuffer-window))) + (sly-curry #'sly-autodoc--async% context multilinep))) + +(defun sly-autodoc--async% (context multilinep doc) + (cl-destructuring-bind (doc &optional cache-p) doc + (unless (eq doc :not-available) + (when cache-p + (setq sly-autodoc--cache-last-context context) + (setq sly-autodoc--cache-last-autodoc doc)) + ;; Now that we've got our information, + ;; get it to the user ASAP. + (when (eldoc-display-message-p) + (eldoc-message (format "%s" (sly-autodoc--format doc multilinep))))))) + + +;;; Minor mode definition +(defvar sly-autodoc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-d A") 'sly-autodoc) + map)) + +(define-minor-mode sly-autodoc-mode + "Toggle echo area display of Lisp objects at point." + nil nil nil + (cond (sly-autodoc-mode + (set (make-local-variable 'eldoc-documentation-function) 'sly-autodoc) + (set (make-local-variable 'eldoc-minor-mode-string) "") + (eldoc-mode sly-autodoc-mode)) + (t + (eldoc-mode -1) + (set (make-local-variable 'eldoc-documentation-function) nil) + (set (make-local-variable 'eldoc-minor-mode-string) " ElDoc")))) + +(provide 'sly-autodoc) blob - /dev/null blob + ceda2fc8bf2981d9dcaaed14b9320fedfc7964ac (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-fancy-inspector.el @@ -0,0 +1,22 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'sly-parse "lib/sly-parse") + +(define-sly-contrib sly-fancy-inspector + "Fancy inspector for CLOS objects." + (:authors "Marco Baringer and others") + (:license "GPL") + (:slynk-dependencies slynk/fancy-inspector)) + +(defun sly-inspect-definition () + "Inspect definition at point" + (interactive) + (sly-inspect (sly-definition-at-point))) + +(defun sly-disassemble-definition () + "Disassemble definition at point" + (interactive) + (sly-eval-describe `(slynk:disassemble-form + ,(sly-definition-at-point t)))) + +(provide 'sly-fancy-inspector) blob - /dev/null blob + aee84993565672d128c9479b545ce48b22ec76b0 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-fancy-trace.el @@ -0,0 +1,68 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'sly-parse "lib/sly-parse") + +(define-sly-contrib sly-fancy-trace + "Enhanced version of sly-trace capable of tracing local functions, +methods, setf functions, and other entities supported by specific +slynk:slynk-toggle-trace backends. Invoke via C-u C-t." + (:authors "Matthias Koeppe " + "Tobias C. Rittweiler ") + (:license "GPL")) + +(defun sly-trace-query (spec) + "Ask the user which function to trace; SPEC is the default. +The result is a string." + (cond ((null spec) + (sly-read-from-minibuffer "(Un)trace: ")) + ((stringp spec) + (sly-read-from-minibuffer "(Un)trace: " spec)) + ((symbolp spec) ; `sly-extract-context' can return symbols. + (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + (t + (sly-dcase spec + ((setf n) + (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:defun n) + (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string n))) + ((:defgeneric n) + (let* ((name (prin1-to-string n)) + (answer (sly-read-from-minibuffer "(Un)trace: " name))) + (cond ((and (string= name answer) + (y-or-n-p (concat "(Un)trace also all " + "methods implementing " + name "? "))) + (prin1-to-string `(:defgeneric ,n))) + (t + answer)))) + ((:defmethod &rest _) + (sly-read-from-minibuffer "(Un)trace: " (prin1-to-string spec))) + ((:call caller callee) + (let* ((callerstr (prin1-to-string caller)) + (calleestr (prin1-to-string callee)) + (answer (sly-read-from-minibuffer "(Un)trace: " + calleestr))) + (cond ((and (string= calleestr answer) + (y-or-n-p (concat "(Un)trace only when " calleestr + " is called by " callerstr "? "))) + (prin1-to-string `(:call ,caller ,callee))) + (t + answer)))) + (((:labels :flet) &rest _) + (sly-read-from-minibuffer "(Un)trace local function: " + (prin1-to-string spec))) + (t (error "Don't know how to trace the spec %S" spec)))))) + +(defun sly-toggle-fancy-trace (&optional using-context-p) + "Toggle trace." + (interactive "P") + (let* ((spec (if using-context-p + (sly-extract-context) + (sly-symbol-at-point))) + (spec (sly-trace-query spec))) + (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec))))) + +;; override sly-toggle-trace-fdefinition +(define-key sly-prefix-map "\C-t" 'sly-toggle-fancy-trace) + +(provide 'sly-fancy-trace) blob - /dev/null blob + 9753b0106750d36ae0ecf343b72b3384062f871d (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-fancy.el @@ -0,0 +1,22 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) + +(define-sly-contrib sly-fancy + "Make SLY fancy." + (:authors "Matthias Koeppe " + "Tobias C Rittweiler ") + (:license "GPL") + (:sly-dependencies sly-mrepl + sly-autodoc + sly-fancy-inspector + sly-fancy-trace + sly-scratch + sly-package-fu + sly-fontifying-fu + sly-trace-dialog + ;; sly-profiler ;; not ready for prime-time yet + sly-stickers + sly-indentation + sly-tramp)) + +(provide 'sly-fancy) blob - /dev/null blob + b6050ba8b1111b25c4987ba06a519afe7488b181 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-fontifying-fu.el @@ -0,0 +1,206 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'sly-parse "lib/sly-parse") +(require 'font-lock) +(require 'cl-lib) + +;;; Fontify WITH-FOO, DO-FOO, and DEFINE-FOO like standard macros. +;;; Fontify CHECK-FOO like CHECK-TYPE. +(defvar sly-additional-font-lock-keywords + '(("(\\(\\(\\s_\\|\\w\\)*:\\(define-\\|do-\\|with-\\|without-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ("(\\(\\(define-\\|do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ("(\\(check-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face) + ("(\\(assert-\\(\\s_\\|\\w\\)*\\)" 1 font-lock-warning-face))) + +;;;; Specially fontify forms suppressed by a reader conditional. +(defcustom sly-highlight-suppressed-forms t + "Display forms disabled by reader conditionals as comments." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'sly-mode) + +(define-sly-contrib sly-fontifying-fu + "Additional fontification tweaks: +Fontify WITH-FOO, DO-FOO, DEFINE-FOO like standard macros. +Fontify CHECK-FOO like CHECK-TYPE." + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:on-load + (font-lock-add-keywords + 'lisp-mode sly-additional-font-lock-keywords) + (when sly-highlight-suppressed-forms + (sly-activate-font-lock-magic))) + (:on-unload + ;; FIXME: remove `sly-search-suppressed-forms', and remove the + ;; extend-region hook. + (font-lock-remove-keywords + 'lisp-mode sly-additional-font-lock-keywords))) + +(defface sly-reader-conditional-face + '((t (:inherit font-lock-comment-face))) + "Face for compiler notes while selected." + :group 'sly-mode-faces) + +(defvar sly-search-suppressed-forms-match-data (list nil nil)) + +(defun sly-search-suppressed-forms-internal (limit) + (when (search-forward-regexp sly-reader-conditionals-regexp limit t) + (let ((start (match-beginning 0)) ; save match data + (state (sly-current-parser-state))) + (if (or (nth 3 state) (nth 4 state)) ; inside string or comment? + (sly-search-suppressed-forms-internal limit) + (let* ((char (char-before)) + (expr (read (current-buffer))) + (val (sly-eval-feature-expression expr))) + (when (<= (point) limit) + (if (or (and (eq char ?+) (not val)) + (and (eq char ?-) val)) + ;; If `sly-extend-region-for-font-lock' did not + ;; fully extend the region, the assertion below may + ;; fail. This should only happen on XEmacs and older + ;; versions of GNU Emacs. + (ignore-errors + (forward-sexp) (backward-sexp) + ;; Try to suppress as far as possible. + (sly-forward-sexp) + (cl-assert (<= (point) limit)) + (let ((md (match-data nil sly-search-suppressed-forms-match-data))) + (setf (cl-first md) start) + (setf (cl-second md) (point)) + (set-match-data md) + t)) + (sly-search-suppressed-forms-internal limit)))))))) + +(defun sly-search-suppressed-forms (limit) + "Find reader conditionalized forms where the test is false." + (when (and sly-highlight-suppressed-forms + (sly-connected-p)) + (let ((result 'retry)) + (while (and (eq result 'retry) (<= (point) limit)) + (condition-case condition + (setq result (sly-search-suppressed-forms-internal limit)) + (end-of-file ; e.g. #+( + (setq result nil)) + ;; We found a reader conditional we couldn't process for + ;; some reason; however, there may still be other reader + ;; conditionals before `limit'. + (invalid-read-syntax ; e.g. #+#.foo + (setq result 'retry)) + (scan-error ; e.g. #+nil (foo ... + (setq result 'retry)) + (sly-incorrect-feature-expression ; e.g. #+(not foo bar) + (setq result 'retry)) + (sly-unknown-feature-expression ; e.g. #+(foo) + (setq result 'retry)) + (error + (setq result nil) + (sly-warning + (concat "Caught error during fontification while searching for forms\n" + "that are suppressed by reader-conditionals. The error was: %S.") + condition)))) + result))) + + +(defun sly-search-directly-preceding-reader-conditional () + "Search for a directly preceding reader conditional. Return its +position, or nil." + ;;; We search for a preceding reader conditional. Then we check that + ;;; between the reader conditional and the point where we started is + ;;; no other intervening sexp, and we check that the reader + ;;; conditional is at the same nesting level. + (condition-case nil + (let* ((orig-pt (point)) + (reader-conditional-pt + (search-backward-regexp sly-reader-conditionals-regexp + ;; We restrict the search to the + ;; beginning of the /previous/ defun. + (save-excursion + (beginning-of-defun) + (point)) + t))) + (when reader-conditional-pt + (let* ((parser-state + (parse-partial-sexp + (progn (goto-char (+ reader-conditional-pt 2)) + (forward-sexp) ; skip feature expr. + (point)) + orig-pt)) + (paren-depth (car parser-state)) + (last-sexp-pt (cl-caddr parser-state))) + (if (and paren-depth + (not (cl-plusp paren-depth)) ; no '(' in between? + (not last-sexp-pt)) ; no complete sexp in between? + reader-conditional-pt + nil)))) + (scan-error nil))) ; improper feature expression + + +;;; We'll push this onto `font-lock-extend-region-functions'. In past, +;;; we didn't do so which made our reader-conditional font-lock magic +;;; pretty unreliable (it wouldn't highlight all suppressed forms, and +;;; worked quite non-deterministic in general.) +;;; +;;; Cf. _Elisp Manual_, 23.6.10 Multiline Font Lock Constructs. +;;; +;;; We make sure that `font-lock-beg' and `font-lock-end' always point +;;; to the beginning or end of a toplevel form. So we never miss a +;;; reader-conditional, or point in mid of one. +(defvar font-lock-beg) ; shoosh compiler +(defvar font-lock-end) + +(defun sly-extend-region-for-font-lock () + (when sly-highlight-suppressed-forms + (condition-case c + (let (changedp) + (cl-multiple-value-setq (changedp font-lock-beg font-lock-end) + (sly-compute-region-for-font-lock font-lock-beg font-lock-end)) + changedp) + (error + (sly-warning + (concat "Caught error when trying to extend the region for fontification.\n" + "The error was: %S\n" + "Further: font-lock-beg=%d, font-lock-end=%d.") + c font-lock-beg font-lock-end))))) + +(defsubst sly-beginning-of-tlf () + (let ((pos (syntax-ppss-toplevel-pos (sly-current-parser-state)))) + (if pos (goto-char pos)))) + +(defun sly-compute-region-for-font-lock (orig-beg orig-end) + (let ((beg orig-beg) + (end orig-end)) + (goto-char beg) + (sly-beginning-of-tlf) + (cl-assert (not (cl-plusp (nth 0 (sly-current-parser-state))))) + (setq beg (let ((pt (point))) + (cond ((> (- beg pt) 20000) beg) + ((sly-search-directly-preceding-reader-conditional)) + (t pt)))) + (goto-char end) + (while (search-backward-regexp sly-reader-conditionals-regexp beg t) + (setq end (max end (save-excursion + (ignore-errors (sly-forward-reader-conditional)) + (point))))) + (cl-values (or (/= beg orig-beg) (/= end orig-end)) beg end))) + + +(defun sly-activate-font-lock-magic () + (font-lock-add-keywords + 'lisp-mode + `((sly-search-suppressed-forms 0 ,''sly-reader-conditional-face t))) + + (add-hook 'lisp-mode-hook + #'(lambda () + (add-hook 'font-lock-extend-region-functions + 'sly-extend-region-for-font-lock t t)))) + + +;;; Compile hotspots +;;; +(sly-byte-compile-hotspots + '(sly-extend-region-for-font-lock + sly-compute-region-for-font-lock + sly-search-directly-preceding-reader-conditional + sly-search-suppressed-forms + sly-beginning-of-tlf)) + +(provide 'sly-fontifying-fu) blob - /dev/null blob + 7524b01275e7350ab1d1bc78eee52b8ce249f194 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-indentation.el @@ -0,0 +1,31 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'cl-lib) +(require 'sly-cl-indent "lib/sly-cl-indent") + +(define-sly-contrib sly-indentation + "Contrib interfacing `sly-cl-indent' and SLY." + (:slynk-dependencies slynk/indentation) + (:on-load + (setq sly--lisp-indent-current-package-function 'sly-current-package))) + +(defun sly-update-system-indentation (symbol indent packages) + (let ((list (gethash symbol sly-common-lisp-system-indentation)) + (ok nil)) + (if (not list) + (puthash symbol (list (cons indent packages)) + sly-common-lisp-system-indentation) + (dolist (spec list) + (cond ((equal (car spec) indent) + (dolist (p packages) + (unless (member p (cdr spec)) + (push p (cdr spec)))) + (setf ok t)) + (t + (setf (cdr spec) + (cl-set-difference (cdr spec) packages :test 'equal))))) + (unless ok + (puthash symbol (cons (cons indent packages) list) + sly-common-lisp-system-indentation))))) + +(provide 'sly-indentation) blob - /dev/null blob + 25d49fe1cffe5fff7a7e732dc9b384a63b04dff1 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-mrepl.el @@ -0,0 +1,1568 @@ +;; -*- lexical-binding: t -*- An experimental implementation of +;; multiple REPLs multiplexed over a single Slime socket. M-x +;; sly-mrepl or M-x sly-mrepl-new create new REPL buffers. +;; +(require 'sly) +(require 'sly-autodoc) +(require 'cl-lib) +(require 'comint) + +(define-sly-contrib sly-mrepl + "Multiple REPLs." + (:license "GPL") + (:sly-dependencies sly-autodoc) + (:slynk-dependencies slynk/mrepl) + (:on-load + ;; Define a new "part action" for the `sly-part' buttons and change + ;; the `sly-inspector-part', `sly-db-local-variable' and + ;; `sly-trace-dialog-part' to include it. + ;; + (sly-button-define-part-action sly-mrepl-copy-part-to-repl + "Copy to REPL" (kbd "M-RET")) + (sly-button-define-part-action sly-mrepl-copy-call-to-repl + "Copy call to REPL" (kbd "M-S-")) + (button-type-put 'sly-inspector-part + 'sly-mrepl-copy-part-to-repl + 'sly-inspector-copy-part-to-repl) + (button-type-put 'sly-db-local-variable + 'sly-mrepl-copy-part-to-repl + 'sly-db-copy-part-to-repl) + (button-type-put 'sly-apropos-symbol + 'sly-mrepl-copy-part-to-repl + 'sly-apropos-copy-symbol-to-repl) + (button-type-put 'sly-db-frame + 'sly-mrepl-copy-call-to-repl + 'sly-db-copy-call-to-repl) + (eval-after-load "sly-trace-dialog" + `(progn + (button-type-put 'sly-trace-dialog-part + 'sly-mrepl-copy-part-to-repl + 'sly-trace-dialog-copy-part-to-repl) + (button-type-put 'sly-trace-dialog-spec + 'sly-mrepl-copy-call-to-repl + 'sly-trace-dialog-copy-call-to-repl))) + ;; Make C-c ~ bring popup REPL + ;; + (define-key sly-mode-map (kbd "C-c ~") 'sly-mrepl-sync) + (define-key sly-mode-map (kbd "C-c C-z") 'sly-mrepl) + (define-key sly-selector-map (kbd "~") 'sly-mrepl-sync) + (define-key sly-selector-map (kbd "r") 'sly-mrepl) + + ;; Insinuate ourselves in hooks + ;; + (add-hook 'sly-connected-hook 'sly-mrepl-on-connection) + (add-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls) + ;; The connection list is also tweaked + ;; + (setq sly-connection-list-button-action + #'(lambda (process) + (let ((sly-default-connection process)) + (sly-mrepl 'pop-to-buffer))))) + (:on-unload + ;; FIXME: This `:on-unload' is grossly incomplete + ;; + (remove-hook 'sly-connected-hook 'sly-mrepl-on-connection) + (remove-hook 'sly-net-process-close-hooks 'sly-mrepl--teardown-repls))) + + +;; User-visible variables +;; +(defvar sly-mrepl-mode-hook nil + "Functions run after `sly-mrepl-mode' is set up") + +(defvar sly-mrepl-hook nil + "Functions run after `sly-mrepl-new' sets up a REPL.") + +(defvar sly-mrepl-runonce-hook nil + "Functions run once after `sly-mrepl-new' sets up a REPL. + +After running the contents of this hook its default value is +emptied. See also `sly-mrepl-hook'") + +(defvar sly-mrepl-output-filter-functions comint-preoutput-filter-functions + "List of functions filtering Slynk's REPL output. +This variables behaves like `comint-preoutput-filter-functions', +for output printed to the REPL (not for evaluation results)") + +(defvar sly-mrepl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'sly-mrepl-return) + (define-key map (kbd "TAB") 'sly-mrepl-indent-and-complete-symbol) + (define-key map (kbd "C-c C-b") 'sly-interrupt) + (define-key map (kbd "C-c C-c") 'sly-interrupt) + (define-key map (kbd "C-c C-o") 'sly-mrepl-clear-recent-output) + (define-key map (kbd "C-c M-o") 'sly-mrepl-clear-repl) + (define-key map (kbd "M-p") 'sly-mrepl-previous-input-or-button) + (define-key map (kbd "M-n") 'sly-mrepl-next-input-or-button) + (define-key map (kbd "C-M-p") 'sly-button-backward) + (define-key map (kbd "C-M-n") 'sly-button-forward) + map)) + +(defvar sly-mrepl-pop-sylvester 'on-connection) + +(defface sly-mrepl-prompt-face + `((t (:inherit font-lock-builtin-face))) + "Face for the regular MREPL prompt." + :group 'sly-mode-faces) + +(defface sly-mrepl-note-face + `((t (:inherit font-lock-keyword-face))) + "Face for the MREPL notes." + :group 'sly-mode-faces) + +(defface sly-mrepl-output-face + '((((class color) + (background dark)) + (:foreground "VioletRed1")) + (((class color) + (background light)) + (:foreground "steel blue")) + (t + (:bold t :italic t))) + "Face for the regular MREPL prompt." + :group 'sly-mode-faces) + + +;; Internal variables +;; +(defvar sly-mrepl--remote-channel nil) +(defvar sly-mrepl--local-channel nil) +(defvar sly-mrepl--read-mark nil) +(defvar sly-mrepl--output-mark nil) +(defvar sly-mrepl--dedicated-stream nil) +(defvar sly-mrepl--last-prompt-overlay nil) +(defvar sly-mrepl--pending-output nil + "Output that can't be inserted right now.") +(defvar sly-mrepl--dedicated-stream-hooks) +(defvar sly-mrepl--history-separator "####\n") +(defvar sly-mrepl--dirty-history nil) + + +;; Major mode +;; +(define-derived-mode sly-mrepl-mode comint-mode "mrepl" + (sly-mode 1) + (cl-loop for (var value) + in `((comint-use-prompt-regexp nil) + (comint-inhibit-carriage-motion t) + (comint-input-sender sly-mrepl--input-sender) + (comint-output-filter-functions nil) + (comint-input-filter-functions nil) + (comint-history-isearch dwim) + (comint-input-ignoredups t) + (comint-input-history-ignore "^;") + (comint-prompt-read-only t) + (comint-process-echoes nil) + (comint-completion-addsuffix "") + (indent-line-function lisp-indent-line) + (sly-mrepl--read-mark nil) + (sly-mrepl--pending-output nil) + (sly-mrepl--output-mark ,(point-marker)) + (sly-mrepl--last-prompt-overlay ,(make-overlay 0 0 nil nil)) + (sly-find-buffer-package-function sly-mrepl-guess-package) + (sly-autodoc-inhibit-autodoc + sly-mrepl-inside-string-or-comment-p) + (mode-line-process nil) + (parse-sexp-ignore-comments t) + (syntax-propertize-function sly-mrepl--syntax-propertize) + (forward-sexp-function sly-mrepl--forward-sexp) + (comint-scroll-show-maximum-output nil) + (comint-scroll-to-bottom-on-input nil) + (comint-scroll-to-bottom-on-output nil) + (inhibit-field-text-motion nil) + (lisp-indent-function sly-common-lisp-indent-function) + (open-paren-in-column-0-is-defun-start nil) + (buffer-file-coding-system utf-8-unix) + ;; Paredit workaround (see + ;; https://github.com/joaotavora/sly/issues/110) + (paredit-override-check-parens-function (lambda (_c) t)) + (comment-start ";")) + do (set (make-local-variable var) value)) + (set-marker-insertion-type sly-mrepl--output-mark nil) + (add-hook 'kill-emacs-hook 'sly-mrepl--save-all-histories) + ;;(set (make-local-variable 'comint-get-old-input) 'ielm-get-old-input) + (set-syntax-table lisp-mode-syntax-table) + (set-keymap-parent sly-mrepl-mode-map nil) + + ;; The REPL buffer has interactive text buttons + (sly-interactive-buttons-mode 1) + + ;; Add hooks to isearch-mode placed strategically after the ones + ;; set by comint.el itself. + ;; + (add-hook 'isearch-mode-hook 'sly-mrepl--setup-comint-isearch t t) + (add-hook 'isearch-mode-end-hook 'sly-mrepl--teardown-comint-isearch t t) + + ;; Add a post-command-handler + ;; + (add-hook 'post-command-hook 'sly-mrepl--highlight-backreferences-maybe t t)) + + +;;; Channel methods +(sly-define-channel-type listener) + +(sly-define-channel-method listener :write-values (results) + (with-current-buffer (sly-channel-get self 'buffer) + (sly-mrepl--insert-results results))) + +(sly-define-channel-method listener :evaluation-aborted (&optional condition) + (with-current-buffer (sly-channel-get self 'buffer) + (sly-mrepl--catch-up) + (sly-mrepl--insert-note (format "Evaluation aborted on %s" condition)))) + +(sly-define-channel-method listener :write-string (string) + (with-current-buffer (sly-channel-get self 'buffer) + (sly-mrepl--insert-output string))) + +(sly-define-channel-method listener :set-read-mode (mode) + (with-current-buffer (sly-channel-get self 'buffer) + (cl-macrolet ((assert-soft + (what) `(unless ,what + (sly-warning + ,(format "Expectation failed: %s" what))))) + (let ((inhibit-read-only t)) + (cl-ecase mode + (:read + (assert-soft (null sly-mrepl--read-mark)) + ;; Give a chance for output to come in before we block it + ;; during the read. + (sly-mrepl--accept-process-output) + (setq sly-mrepl--read-mark (point)) + (add-text-properties (1- (point)) (point) + `(rear-nonsticky t)) + (sly-message "REPL now waiting for input to read")) + (:finished-reading + (assert-soft (integer-or-marker-p sly-mrepl--read-mark)) + (when sly-mrepl--read-mark + (add-text-properties (1- sly-mrepl--read-mark) (point) + `(face bold read-only t))) + (setq sly-mrepl--read-mark nil) + ;; github#456 need to flush any output that has overtaken + ;; the set-read-mode rpc. + (when sly-mrepl--pending-output + (sly-mrepl--insert-output "\n")) + (sly-message "REPL back to normal evaluation mode"))))))) + +(sly-define-channel-method listener :prompt (&rest prompt-args) + (with-current-buffer (sly-channel-get self 'buffer) + (apply #'sly-mrepl--insert-prompt prompt-args))) + +(sly-define-channel-method listener :open-dedicated-output-stream + (port _coding-system) + (with-current-buffer (sly-channel-get self 'buffer) + ;; HACK: no coding system + (set (make-local-variable 'sly-mrepl--dedicated-stream) + (sly-mrepl--open-dedicated-stream self port nil)))) + +(sly-define-channel-method listener :clear-repl-history () + (with-current-buffer (sly-channel-get self 'buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (sly-mrepl--insert-note "Cleared REPL history")))) + +(sly-define-channel-method listener :server-side-repl-close () + (with-current-buffer (sly-channel-get self 'buffer) + (sly-mrepl--teardown "Server side close" 'dont-signal-server))) + + +;;; Button type +;;; +(define-button-type 'sly-mrepl-part :supertype 'sly-part + 'sly-button-inspect + #'(lambda (entry-idx value-idx) + (sly-eval-for-inspector `(slynk-mrepl:inspect-entry + ,sly-mrepl--remote-channel + ,entry-idx + ,value-idx) + :inspector-name (sly-maybe-read-inspector-name))) + 'sly-button-describe + #'(lambda (entry-idx value-idx) + (sly-eval-describe `(slynk-mrepl:describe-entry ,sly-mrepl--remote-channel + ,entry-idx + ,value-idx))) + 'sly-button-pretty-print + #'(lambda (entry-idx value-idx) + (sly-eval-describe `(slynk-mrepl:pprint-entry ,sly-mrepl--remote-channel + ,entry-idx + ,value-idx))) + 'sly-mrepl-copy-part-to-repl 'sly-mrepl--copy-part-to-repl) + + +;;; Internal functions +;;; +(defun sly-mrepl--buffer-name (connection &optional handle) + (sly-buffer-name :mrepl :connection connection + :suffix handle)) + +(defun sly-mrepl--teardown-repls (process) + (cl-loop for buffer in (buffer-list) + when (buffer-live-p buffer) + do (with-current-buffer buffer + (when (and (eq major-mode 'sly-mrepl-mode) + (eq sly-buffer-connection process)) + (sly-mrepl--teardown (process-get process + 'sly-net-close-reason)))))) + +(defun sly-mrepl--process () (get-buffer-process (current-buffer))) ;stupid + +(defun sly-mrepl--mark () + "Returns a marker to the end of the last prompt." + (let ((proc (sly-mrepl--process))) + (unless proc (sly-user-error "Not in a connected REPL")) + (process-mark proc))) + +(defun sly-mrepl--safe-mark () + "Like `sly-mrepl--mark', but safe if there's no process." + (if (sly-mrepl--process) (sly-mrepl--mark) (point-max))) + +(defmacro sly-mrepl--commiting-text (props &rest body) + (declare (debug (sexp &rest form)) + (indent 1)) + (let ((start-sym (cl-gensym))) + `(let ((,start-sym (marker-position (sly-mrepl--mark))) + (inhibit-read-only t)) + ,@body + (add-text-properties ,start-sym (sly-mrepl--mark) + (append '(read-only t front-sticky (read-only)) + ,props))))) + +(defun sly-mrepl--forward-sexp (n) + "Just like `forward-sexp' unless point it at prompt start. +In that case, moving a sexp backward does nothing." + (if (or (cl-plusp n) + (/= (point) (sly-mrepl--safe-mark))) + (let ((forward-sexp-function nil)) + (forward-sexp n)))) + +(defun sly-mrepl--syntax-propertize (beg end) + "Make everything up to current prompt comment syntax." + (remove-text-properties beg end '(syntax-table nil)) + (let ((end (min end (sly-mrepl--safe-mark))) + (beg beg)) + (when (> end beg) + (unless (nth 8 (syntax-ppss beg)) + (add-text-properties beg (1+ beg) + `(syntax-table ,(string-to-syntax "!")))) + (add-text-properties (1- end) end + `(syntax-table ,(string-to-syntax "!")))))) + +(defun sly-mrepl--call-with-repl (repl-buffer fn) + (with-current-buffer repl-buffer + (cl-loop + while (not (buffer-local-value 'sly-mrepl--remote-channel + (current-buffer))) + do + (sly-warning "Waiting for a REPL to be setup for %s" + (sly-connection-name (sly-current-connection))) + (sit-for 0.5)) + (funcall fn))) + +(defmacro sly-mrepl--with-repl (repl-buffer &rest body) + (declare (indent 1) (debug (sexp &rest form))) + `(sly-mrepl--call-with-repl ,repl-buffer #'(lambda () ,@body))) + +(defun sly-mrepl--insert (string &optional face) + (sly-mrepl--commiting-text (when face + `(face ,face font-lock-face ,face)) + (comint-output-filter (sly-mrepl--process) + (propertize string 'sly-mrepl-break-output t)))) + +(defun sly-mrepl--break-output-p (pos) + (and (not (eq ?\n (char-after pos))) + (get-char-property pos 'sly-mrepl-break-output))) + +(defun sly-mrepl--insert-output (string &optional face nofilters) + (cond ((and (not sly-mrepl--read-mark) string) + (let ((inhibit-read-only t) + (start (marker-position sly-mrepl--output-mark)) + (face (or face + 'sly-mrepl-output-face))) + + (save-excursion + (goto-char sly-mrepl--output-mark) + (cond ((and (not (bobp)) + (sly-mrepl--break-output-p (1- start)) + (not (zerop (current-column)))) + (insert-before-markers "\n"))) + (setq string + (propertize (concat sly-mrepl--pending-output string) + 'face face + 'font-lock-face face)) + (setq sly-mrepl--pending-output nil) + (unless nofilters + (run-hook-wrapped + 'sly-mrepl-output-filter-functions + (lambda (fn) + (setq string (funcall fn string)) + nil))) + (insert-before-markers string) + (cond ((and (not (zerop (current-column))) + (sly-mrepl--break-output-p (point))) + (save-excursion (insert "\n")))) + (add-text-properties start sly-mrepl--output-mark + `(read-only t front-sticky (read-only) + field sly-mrepl--output))))) + (t + (setq sly-mrepl--pending-output + (concat sly-mrepl--pending-output string)) + (sly-message "Some output saved for later insertion")))) + +(defun sly-mrepl--insert-note (string &optional face) + (let* ((face (or face 'sly-mrepl-note-face)) + (string (replace-regexp-in-string "^" "; " string))) + (cond ((sly-mrepl--process) + ;; notes are inserted "synchronously" with the process mark process + (sly-mrepl--ensure-newline) + (sly-mrepl--insert string face)) + (t + ;; If no process yet, fall back to the simpler strategy. + (sly-mrepl--insert-output string face))))) + +(defun sly-mrepl--send-input-sexp () + (goto-char (point-max)) + (save-excursion + (skip-chars-backward "\n\t\s") + (delete-region (max (point) + (sly-mrepl--mark)) + (point-max))) + (buffer-disable-undo) + (overlay-put sly-mrepl--last-prompt-overlay 'face 'highlight) + (set (make-local-variable 'sly-mrepl--dirty-history) t) + (sly-mrepl--commiting-text + `(field sly-mrepl-input + keymap ,(let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'sly-mrepl-insert-input) + (define-key map [return] 'sly-mrepl-insert-input) + (define-key map [mouse-2] 'sly-mrepl-insert-input) + map)) + (comint-send-input)) + (sly-mrepl--ensure-prompt-face)) + +(defun sly-mrepl--ensure-newline () + (unless (save-excursion + (goto-char (sly-mrepl--mark)) + (zerop (current-column))) + (sly-mrepl--insert "\n"))) + +(defun sly-mrepl--accept-process-output () + (when (and sly-mrepl--dedicated-stream + (process-live-p sly-mrepl--dedicated-stream)) + ;; This non-blocking call should be enough to allow asynch calls + ;; to `sly-mrepl--insert-output' to still see the correct value + ;; for `sly-mrepl--output-mark' just before we call + ;; `sly-mrepl--catch-up'. + (while (accept-process-output sly-mrepl--dedicated-stream + 0 + (and (eq (window-system) 'w32) 1))))) + +(defun sly-mrepl--ensure-prompt-face () + "Override `comint.el''s use of `comint-highlight-prompt'." + (let ((inhibit-read-only t)) + (add-text-properties (overlay-start sly-mrepl--last-prompt-overlay) + (overlay-end sly-mrepl--last-prompt-overlay) + '(font-lock-face sly-mrepl-prompt-face)))) + +(defun sly-mrepl-default-prompt (_package + nickname + error-level + _entry-idx + _condition) + "Compute default SLY prompt string. +Suitable for `sly-mrepl-prompt-formatter'." + (concat + (when (cl-plusp error-level) + (concat (sly-make-action-button + (format "[%d]" error-level) + #'sly-db-pop-to-debugger-maybe) + " ")) + (propertize + (concat nickname "> ") + 'face 'sly-mrepl-prompt-face + 'font-lock-face 'sly-mrepl-prompt-face))) + +(defcustom sly-mrepl-prompt-formatter #'sly-mrepl-default-prompt + "Compute propertized string to use as REPL prompt. +Value is a function passed at least 5 arguments with the +following signature: + +(PACKAGE NICKNAME ERROR-LEVEL NEXT-ENTRY-IDX CONDITION &REST) + +PACKAGE is a string denoring the full name of the current +package. NICKNAME is the shortest or preferred nickname of +PACKAGE, according to the Lisp variables +SLYNK:*CANONICAL-PACKAGE-NICKNAMES* and +SLYNK:*AUTO-ABBREVIATE-DOTTED-PACKAGES*. ERROR-LEVEL is a +integer counting the number of outstanding errors. +NEXT-ENTRY-IDX is a number identifying future evaluation results +for backreferencing purposes. Depending on ERROR-LEVEL, +CONDITION is either nil or a string containing the printed +representation of the outstanding condition that caused the +current ERROR-LEVEL." + :type 'function + :group 'sly) + +(defun sly-mrepl--insert-prompt (package nickname error-level + &optional next-entry-idx condition) + (sly-mrepl--accept-process-output) + (overlay-put sly-mrepl--last-prompt-overlay 'face 'bold) + (when condition + (sly-mrepl--insert-note (format "Debugger entered on %s" condition))) + (sly-mrepl--ensure-newline) + (sly-mrepl--catch-up) + (let ((beg (marker-position (sly-mrepl--mark)))) + (sly-mrepl--insert + (propertize + (funcall sly-mrepl-prompt-formatter + package + nickname + error-level + next-entry-idx + condition) + 'sly-mrepl--prompt (downcase package))) + (move-overlay sly-mrepl--last-prompt-overlay beg (sly-mrepl--mark))) + (sly-mrepl--ensure-prompt-face) + (buffer-disable-undo) + (buffer-enable-undo)) + +(defun sly-mrepl--copy-part-to-repl (entry-idx value-idx) + (sly-mrepl--copy-objects-to-repl + `(,entry-idx ,value-idx) + :before (format "Returning value %s of history entry %s" + value-idx entry-idx))) + +(cl-defun sly-mrepl--eval-for-repl + (slyfun-and-args + &key insert-p before-prompt after-prompt (pop-to-buffer t)) + "Evaluate SLYFUN-AND-ARGS in Slynk, then call callbacks. + +SLYFUN-AND-ARGS is (SLYFUN . ARGS) and is called in +Slynk. SLYFUN's multiple return values are captured in a list and +passed to the optional unary callbacks BEFORE-PROMPT and +AFTER-PROMPT, called before or after prompt insertion, +respectively. + +If INSERT-P is non-nil, SLYFUN's results are printable +representations of Slynk objects and should be inserted into the +REPL. POP-TO-BUFFER says whether to pop the REPL buffer." + (sly-eval-async `(slynk-mrepl:eval-for-mrepl + ,sly-mrepl--remote-channel + ',(car slyfun-and-args) + ,@(cdr slyfun-and-args)) + (lambda (prompt-args-and-results) + (cl-destructuring-bind (prompt-args results) + prompt-args-and-results + (goto-char (sly-mrepl--mark)) + (let ((saved-text (buffer-substring (point) (point-max)))) + (delete-region (point) (point-max)) + (sly-mrepl--catch-up) + (when before-prompt + (funcall before-prompt results)) + (when insert-p + (sly-mrepl--insert-results results)) + (apply #'sly-mrepl--insert-prompt prompt-args) + (when pop-to-buffer + (pop-to-buffer (current-buffer))) + (goto-char (sly-mrepl--mark)) + (insert saved-text) + (when after-prompt + (funcall after-prompt results))))))) + +(cl-defun sly-mrepl--copy-objects-to-repl + (method-args &key before after (pop-to-buffer t)) + "Recall objects in the REPL history as a new entry. +METHOD-ARGS are SLYNK-MREPL:COPY-TO-REPL's optional args. If nil +, consider the globally saved objects that +SLYNK-MREPL:GLOBALLY-SAVE-OBJECT stored. Otherwise, it is a +list (ENTRY-IDX VALUE-IDX). BEFORE and AFTER as in +`sly-mrepl--save-and-copy-for-repl' POP-TO-BUFFER as in +`sly-mrepl--eval-for-repl'." + (sly-mrepl--eval-for-repl + `(slynk-mrepl:copy-to-repl + ,@method-args) + :before-prompt (if (stringp before) + (lambda (objects) + (sly-mrepl--insert-note before) + (sly-mrepl--insert-results objects)) + before) + :after-prompt after + :pop-to-buffer pop-to-buffer)) + +(defun sly-mrepl--make-result-button (result idx) + (sly--make-text-button (car result) nil + :type 'sly-mrepl-part + 'part-args (list (cadr result) idx) + 'part-label (format "REPL Result") + 'sly-mrepl--result result + 'sly-button-search-id (sly-button-next-search-id))) + +(defun sly-mrepl--insert-results (results) + (let* ((comint-preoutput-filter-functions nil)) + (if (null results) + (sly-mrepl--insert-note "No values") + (cl-loop for result in results + for idx from 0 + do + (sly-mrepl--ensure-newline) + (sly-mrepl--insert + (sly-mrepl--make-result-button result idx)))))) + +(defun sly-mrepl--catch-up () + "Synchronize the output mark with the REPL process mark." + (set-marker sly-mrepl--output-mark (sly-mrepl--mark))) + +(defun sly-mrepl--input-sender (_proc string) + (sly-mrepl--send-string (substring-no-properties string))) + +(defun sly-mrepl--send-string (string &optional _command-string) + (sly-mrepl--send `(:process ,string))) + +(defun sly-mrepl--send (msg) + "Send MSG to the remote channel." + (sly-send-to-remote-channel sly-mrepl--remote-channel msg)) + +(defun sly-mrepl--find-buffer (&optional connection thread) + "Find the shortest-named (default) `sly-mrepl' buffer for CONNECTION." + ;; CONNECTION defaults to the `sly-default-connection' passing + ;; through `sly-connection'. Seems to work OK... + ;; + (let* ((connection (or connection + (let ((sly-buffer-connection nil) + (sly-dispatching-connection nil)) + (sly-connection)))) + (repls (cl-remove-if-not + (lambda (x) + (with-current-buffer x + (and (eq major-mode 'sly-mrepl-mode) + (eq sly-buffer-connection connection) + (or (not thread) + (eq thread sly-current-thread))))) + (buffer-list))) + (sorted (cl-sort repls #'< :key (sly-compose #'length #'buffer-name)))) + (car sorted))) + +(defun sly-mrepl--find-create (connection) + (or (sly-mrepl--find-buffer connection) + (sly-mrepl-new connection))) + +(defun sly-mrepl--busy-p () + (>= sly-mrepl--output-mark (sly-mrepl--mark))) + +(defcustom sly-mrepl-history-file-name (expand-file-name "~/.sly-mrepl-history") + "File used to store SLY REPL's input history across sessions." + :type 'file + :group 'sly) + +(defun sly-mrepl--read-input-ring () + (let ((comint-input-ring-separator sly-mrepl--history-separator) + (comint-input-ring-file-name sly-mrepl-history-file-name)) + (comint-read-input-ring))) + +(defcustom sly-mrepl-prevent-duplicate-history 'move + "If non-nil, prevent duplicate entries in input history. + +Otherwise (if nil), input entry are always added to the end of +the history, even if they already occur in the history. + +If the non-nil value is `move', the previously occuring entry is +discarded, i.e. moved to a more recent spot. Any other non-nil +value laves the previous entry untouched and it is the more +recent entry that is discarded." + :type 'symbol + :group 'sly) + +(defun sly-mrepl--merge-and-save-history () + (let* + ;; To merge the file's history with the current buffer's + ;; history, sntart by deep-copying `comint-input-ring' to a + ;; separate variable. + ;; + ((current-ring (copy-tree comint-input-ring 'vectors-too)) + (index (ring-length current-ring)) + (comint-input-ring-separator sly-mrepl--history-separator) + (comint-input-ring-file-name sly-mrepl-history-file-name)) + ;; this sets `comint-input-ring' from the file + ;; + (sly-mrepl--read-input-ring) + ;; loop `current-ring', which potentially contains new entries and + ;; re-add entries to `comint-input-ring', which is now synched + ;; with the file and will be written to disk. Respect + ;; `sly-mrepl-prevent-duplicate-history'. + ;; + (cl-loop for i from (1- index) downto 0 + for item = (ring-ref current-ring i) + for existing-index = (ring-member comint-input-ring item) + do (cond ((and existing-index + (eq sly-mrepl-prevent-duplicate-history 'move)) + (ring-remove comint-input-ring existing-index) + (ring-insert comint-input-ring item)) + ((and existing-index + (not sly-mrepl-prevent-duplicate-history)) + (ring-insert comint-input-ring item)) + (t + (ring-insert comint-input-ring item))) + unless (ring-member comint-input-ring item) + do (ring-insert comint-input-ring item)) + ;; Now save `comint-input-ring' + (let ((coding-system-for-write 'utf-8-unix)) + (comint-write-input-ring)) + (set (make-local-variable 'sly-mrepl--dirty-history) nil))) + +(defun sly-mrepl--save-all-histories () + (cl-loop for buffer in (buffer-list) + do + (with-current-buffer buffer + (when (and (eq major-mode 'sly-mrepl-mode) + sly-mrepl--dirty-history) + (sly-mrepl--merge-and-save-history))))) + +(defun sly-mrepl--teardown (&optional reason dont-signal-server) + (remove-hook 'kill-buffer-hook 'sly-mrepl--teardown t) + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (let ((start (point))) + (unless (zerop (current-column)) (insert "\n")) + (insert (format "; %s" (or reason "REPL teardown"))) + (unless (zerop (current-column)) (insert "\n")) + (insert "; --------------------------------------------------------\n") + (add-text-properties start (point) '(read-only t)))) + (sly-mrepl--merge-and-save-history) + (when sly-mrepl--dedicated-stream + (process-put sly-mrepl--dedicated-stream 'sly-mrepl--channel nil) + (kill-buffer (process-buffer sly-mrepl--dedicated-stream))) + (sly-close-channel sly-mrepl--local-channel) + ;; signal lisp that we're closingq + (unless dont-signal-server + (ignore-errors + ;; uses `sly-connection', which falls back to + ;; `sly-buffer-connection'. If that is closed it's probably + ;; because lisp died from (SLYNK:QUIT-LISP) already, and so + (sly-mrepl--send `(:teardown)))) + (set (make-local-variable 'sly-mrepl--remote-channel) nil) + (when (sly-mrepl--process) + (delete-process (sly-mrepl--process)))) + +(defun sly-mrepl--dedicated-stream-output-filter (process string) + (let* ((channel (process-get process 'sly-mrepl--channel)) + (buffer (and channel + (sly-channel-get channel 'buffer)))) + (if (buffer-live-p buffer) + (with-current-buffer buffer + (when (and (cl-plusp (length string)) + (eq (process-status sly-buffer-connection) 'open)) + (sly-mrepl--insert-output string))) + (sly-warning "No channel in process %s, probably torn down" process)))) + +(defun sly-mrepl--open-dedicated-stream (channel port coding-system) + (let* ((name (format "sly-dds-%s-%s" + (process-get sly-buffer-connection + 'sly--net-connect-counter) + (sly-channel.id channel))) + (stream (open-network-stream + name + (generate-new-buffer + (format " *%s*" name)) + (car (process-contact sly-buffer-connection)) + port)) + (emacs-coding-system (car (cl-find coding-system + sly-net-valid-coding-systems + :key #'cl-third)))) + (set-process-query-on-exit-flag stream nil) + (set-process-plist stream `(sly-mrepl--channel ,channel)) + (set-process-filter stream 'sly-mrepl--dedicated-stream-output-filter) + (set-process-coding-system stream emacs-coding-system emacs-coding-system) + (sly--when-let (secret (sly-secret)) + (sly-net-send secret stream)) + (run-hook-with-args 'sly-mrepl--dedicated-stream-hooks stream) + stream)) + +(cl-defun sly-mrepl--save-and-copy-for-repl + (slyfun-and-args &key repl before after) + "Evaluate SLYFUN-AND-ARGS in Slynk and prepare to copy to REPL. +BEFORE is a string inserted as a note, or a nullary function +which is run just before the object is copied to the +REPL. Optional BEFORE and AFTER are unary functions called with a +list of the saved values' presentations strings and run before +and after the the the prompt are inserted, respectively. BEFORE +can also be a string in which case it is inserted via +`sly-insert-note' followed by the saved values' presentations. +REPL is the REPL buffer to return the objects to." + (sly-eval-async + `(slynk-mrepl:globally-save-object ',(car slyfun-and-args) + ,@(cdr slyfun-and-args)) + #'(lambda (_ignored) + (sly-mrepl--copy-globally-saved-to-repl :before before + :after after + :repl repl)))) + +(cl-defun sly-mrepl--copy-globally-saved-to-repl + (&key before after repl (pop-to-buffer t)) + "Copy last globally saved values to REPL, or active REPL. +BEFORE and AFTER as described in +`sly-mrepl--save-and-copy-for-repl'." + (sly-mrepl--with-repl (or repl + (sly-mrepl--find-create (sly-connection))) + (sly-mrepl--copy-objects-to-repl nil + :before before + :after after + :pop-to-buffer pop-to-buffer))) + +(defun sly-mrepl--insert-call (spec results) + (delete-region (sly-mrepl--mark) (point-max)) + (insert (format + "%s" + `(,spec + ,@(cl-loop for (_object j constant) in results + for i from 0 + collect + (or constant + (make-symbol (format "#v%d:%d" j i)))))))) + +(defun sly-mrepl--assert-mrepl () + (unless (eq major-mode 'sly-mrepl-mode) + (sly-error "Not in a mREPL buffer"))) + + +;;; ELI-like history (and a bugfix) +;;; +;;; +(defcustom sly-mrepl-eli-like-history-navigation nil + "If non-NIL navigate history like ELI. +When this option is active, previous history entries navigated to +by M-p and M-n keep the current input and use it to surround the +history entry navigated to." + :type 'boolean + :group 'sly) + +(defvar sly-mrepl--eli-input nil) + +(defun sly-mrepl--set-eli-input () + (setq sly-mrepl--eli-input + (and sly-mrepl-eli-like-history-navigation + (let* ((offset (- (point) (sly-mrepl--mark))) + (existing (and (> offset 0) + (buffer-substring (sly-mrepl--mark) + (point-max))))) + (when existing + (cons (substring existing 0 offset) + (substring existing offset))))))) + +(defun sly-mrepl--keep-eli-input-maybe () + (when sly-mrepl--eli-input + (save-excursion + (goto-char (sly-mrepl--mark)) + (insert (car sly-mrepl--eli-input)) + (goto-char (point-max)) + (insert (cdr sly-mrepl--eli-input))))) + +(defvar sly-mrepl--eli-input-overlay nil) + +(defun sly-mrepl--surround-with-eli-input-overlay () + (if sly-mrepl--eli-input-overlay + (move-overlay sly-mrepl--eli-input-overlay + (sly-mrepl--mark) (point-max)) + (setq sly-mrepl--eli-input-overlay + (make-overlay (sly-mrepl--mark) (point-max)))) + (overlay-put sly-mrepl--eli-input-overlay + 'before-string (car sly-mrepl--eli-input)) + (overlay-put sly-mrepl--eli-input-overlay + 'after-string (cdr sly-mrepl--eli-input))) + +(defun sly-mrepl--setup-comint-isearch () + ;; Defeat Emacs bug 19572 in Emacs whereby comint refuses to + ;; i-search multi-line history entries. The doc of + ;; `isearch-search-fun-function' should explain the need for this + ;; lambda madness. + ;; + (unless (eq isearch-search-fun-function + 'isearch-search-fun-default) + (set (make-local-variable 'isearch-search-fun-function) + #'(lambda () + #'(lambda (&rest args) + (cl-letf + (((symbol-function + 'comint-line-beginning-position) + #'field-beginning)) + (apply (comint-history-isearch-search) + args)))))) + (sly-mrepl--set-eli-input) + (when sly-mrepl-eli-like-history-navigation + (set (make-local-variable 'isearch-push-state-function) + #'sly-mrepl--isearch-push-state))) + +(defun sly-mrepl--isearch-push-state (&rest args) + (apply #'comint-history-isearch-push-state args) + (unless (memq this-command + '(isearch-backward isearch-forward)) + (sly-mrepl--surround-with-eli-input-overlay))) + +(defun sly-mrepl--teardown-comint-isearch () + (set (make-local-variable 'isearch-search-fun-function) + 'isearch-search-fun-default) + (when (overlayp sly-mrepl--eli-input-overlay) + (delete-overlay sly-mrepl--eli-input-overlay) + (setq sly-mrepl--eli-input-overlay nil)) + (sly-mrepl--keep-eli-input-maybe)) + + +;;; Interactive commands +;;; +(defun sly-mrepl-indent-and-complete-symbol (arg) + "Indent the current line, perform symbol completion or show arglist. +Completion performed by `completion-at-point' or +`company-complete'. If there's no symbol at the point, show the +arglist for the most recently enclosed macro or function." + (interactive "P") + (let ((pos (point)) + (fn (if (bound-and-true-p company-mode) + 'company-complete + 'completion-at-point))) + (indent-for-tab-command arg) + (when (= pos (point)) + (cond ((save-excursion (re-search-backward "[^() \n\t\r]+\\=" nil t)) + (funcall fn)) + ((memq (char-before) '(?\t ?\ )) + (sly-show-arglist)))))) + +(defun sly-mrepl-return (&optional end-of-input) + "If the input is a whole expression, evaluate it and return the result." + (interactive "P") + (cl-assert (sly-connection)) + (cl-assert (process-live-p (sly-mrepl--process)) nil + "No local live process, cannot use this REPL") + (accept-process-output) + (cond ((and + (not sly-mrepl--read-mark) + (sly-mrepl--busy-p)) + (sly-message "REPL is busy")) + ((and (not sly-mrepl--read-mark) + (or (sly-input-complete-p (sly-mrepl--mark) (point-max)) + end-of-input)) + (sly-mrepl--send-input-sexp) + (sly-mrepl--catch-up)) + (sly-mrepl--read-mark + (unless end-of-input + (goto-char (point-max)) + (newline)) + (let ((comint-input-filter (lambda (_s) nil))) + (comint-send-input 'no-newline)) + (sly-mrepl--catch-up)) + (t + (newline-and-indent) + (sly-message "Input not complete")))) + +(defun sly-mrepl-previous-input-or-button (n) + (interactive "p") + (if (>= (point) (sly-mrepl--mark)) + (progn + (unless (memq last-command + '(sly-mrepl-previous-input-or-button + sly-mrepl-next-input-or-button)) + (sly-mrepl--set-eli-input)) + (comint-previous-input n) + (sly-mrepl--keep-eli-input-maybe)) + (sly-button-backward n))) + +(defun sly-mrepl-next-input-or-button (n) + (interactive "p") + (sly-mrepl-previous-input-or-button (- n))) + +(put 'sly-mrepl-next-input-or-button 'sly-button-navigation-command t) +(put 'sly-mrepl-previous-input-or-button 'sly-button-navigation-command t) + +;;;###autoload +(defun sly-mrepl (&optional display-action) + "Find or create the first useful REPL for the default connection. +If supplied, DISPLAY-ACTION is called on the +buffer. Interactively, DISPLAY-ACTION defaults to using +`switch-to-buffer' unless the intended buffer is already visible +in some window, in which case that window is selected." + (interactive (list (lambda (buf) + (let ((w (get-buffer-window buf))) + (if w (select-window w) (switch-to-buffer buf)))))) + (let* ((buffer + (sly-mrepl--find-create (sly-current-connection)))) + (when display-action + (funcall display-action buffer)) + buffer)) + +(defun sly-mrepl-on-connection () + (let* ((inferior-buffer + (and (sly-process) (process-buffer (sly-process)))) + (inferior-window + (and inferior-buffer (get-buffer-window inferior-buffer t)))) + (let ((sly-mrepl-pop-sylvester + (or (eq sly-mrepl-pop-sylvester 'on-connection) + sly-mrepl-pop-sylvester))) + (sly-mrepl 'pop-to-buffer)) + (when inferior-window + (bury-buffer inferior-buffer) + (delete-window inferior-window)) + (goto-char (point-max)))) + +(defun sly-mrepl-new (connection &optional handle) + "Create and setup a new REPL buffer for CONNECTION. +CONNECTION defaults to the current SLY connection. If such a +buffer already exists, or a prefix arg is given, prompt for a +handle to distinguish the new buffer from the existing." + (interactive + ;; FIXME: Notice a subtle bug/feature than when calling + ;; interactively in a buffer which has a connection, but not the + ;; default connection, the new REPL will be for that connection. + (let ((connection (sly-connection))) + (list connection + (if (or (get-buffer (sly-mrepl--buffer-name connection)) + current-prefix-arg) + (sly-read-from-minibuffer + "Nickname for this new REPL? "))))) + (let* ((name (sly-mrepl--buffer-name connection handle)) + (existing (get-buffer name))) + (when (and handle existing) + (sly-user-error "A REPL with that handle already exists")) + ;; Take this oportunity to save any other REPL histories so that + ;; the new REPL will see them. + (sly-mrepl--save-all-histories) + (let* ((local (sly-make-channel sly-listener-channel-methods)) + (buffer (pop-to-buffer name)) + (default-directory (if (file-readable-p default-directory) + default-directory + (expand-file-name "~/")))) + (with-current-buffer buffer + (sly-mrepl-mode) + (when (and (not existing) + (eq sly-mrepl-pop-sylvester t)) + (sly-mrepl--insert-note + (concat "\n" (sly-mrepl-random-sylvester) "\n\n") + 'sly-mrepl-output-face)) + (setq sly-buffer-connection connection) + (start-process (format "sly-pty-%s-%s" + (process-get connection + 'sly--net-connect-counter) + (sly-channel.id local)) + (current-buffer) + nil) + (set-process-query-on-exit-flag (sly-mrepl--process) nil) + (setq header-line-format + (format "Waiting for REPL creation ack for channel %d..." + (sly-channel.id local))) + (sly-channel-put local 'buffer (current-buffer)) + (add-hook 'kill-buffer-hook 'sly-mrepl--teardown nil 'local) + (set (make-local-variable 'sly-mrepl--local-channel) local)) + (sly-eval-async + `(slynk-mrepl:create-mrepl ,(sly-channel.id local)) + (lambda (result) + (cl-destructuring-bind (remote thread-id) result + (with-current-buffer buffer + (sly-mrepl--read-input-ring) + (setq header-line-format nil) + (setq sly-current-thread thread-id) + (set (make-local-variable 'sly-mrepl--remote-channel) remote) + (unwind-protect + (run-hooks 'sly-mrepl-hook 'sly-mrepl-runonce-hook) + (set-default 'sly-mrepl-runonce-hook nil)))))) + buffer))) + +(defun sly-mrepl-insert-input (pos) + (interactive (list (if (mouse-event-p last-input-event) + (posn-point (event-end last-input-event)) + (point)))) + (sly-mrepl--assert-mrepl) + (let* ((pos (if (eq (field-at-pos pos) 'sly-mrepl-input) + pos + (1+ pos))) + (new-input (and + (eq (field-at-pos (1+ pos)) 'sly-mrepl-input) + (field-string-no-properties pos))) + (offset (and new-input + (- (point) (field-beginning pos))))) + (cond (new-input + (goto-char (sly-mrepl--mark)) + (delete-region (point) (point-max)) + (insert (sly-trim-whitespace new-input)) + (goto-char (+ (sly-mrepl--mark) offset))) + (t + (sly-user-error "No input at point"))))) + +(defun sly-mrepl-guess-package (&optional point interactive) + (interactive (list (point) t)) + (let* ((point (or point (point))) + (probe + (previous-single-property-change point + 'sly-mrepl--prompt)) + (package (and probe + (or (get-text-property probe 'sly-mrepl--prompt) + (let ((probe2 + (previous-single-property-change + probe 'sly-mrepl--prompt))) + (and probe2 + (get-text-property probe2 + 'sly-mrepl--prompt))))))) + (when interactive + (sly-message "Guessed package \"%s\"" package)) + package)) + +(define-obsolete-function-alias + 'sly-mrepl-sync-package-and-default-directory 'sly-mrepl-sync + "1.0.0-alpha-3") + +(defun sly-mrepl-sync (&optional package directory expression) + "Go to the REPL, and set Slynk's PACKAGE and DIRECTORY. +Also yank EXPRESSION into the prompt. Interactively gather +PACKAGE and DIRECTORY these values from the current buffer, if +available. In this scenario EXPRESSION is only set if a C-u +prefix argument is given." + (interactive (list (sly-current-package) + (and buffer-file-name + default-directory) + (and current-prefix-arg + (sly-last-expression)))) + (sly-mrepl--with-repl (sly-mrepl--find-create (sly-connection)) + (when directory + (cd directory)) + (sly-mrepl--eval-for-repl + `(slynk-mrepl:sync-package-and-default-directory + :package-name ,package + :directory ,(and directory + (sly-to-lisp-filename directory))) + :insert-p nil + :before-prompt + #'(lambda (results) + (cl-destructuring-bind (package-2 directory-2) results + (sly-mrepl--insert-note + (cond ((and package directory) + (format "Synched package to %s and directory to %s" + package-2 directory-2)) + (directory + (format "Synched directory to %s" directory-2)) + (package + (format "Synched package to %s" package-2)) + (t + (format "Remaining in package %s and directory %s" + package-2 directory-2)))))) + :after-prompt + #'(lambda (_results) + (when expression + (goto-char (point-max)) + (let ((saved (point))) + (insert expression) + (when (string-match "\n" expression) + (indent-region saved (point-max))))))))) + +(defun sly-mrepl-clear-repl () + "Clear all this REPL's output history. +Doesn't clear input history." + (interactive) + (sly-mrepl--assert-mrepl) + (sly-mrepl--send `(:clear-repl-history))) + +(defun sly-mrepl-clear-recent-output () + "Clear this REPL's output between current and last prompt." + (interactive) + (sly-mrepl--assert-mrepl) + (cl-loop for search-start = + (set-marker (make-marker) + (1+ (overlay-start sly-mrepl--last-prompt-overlay))) + then pos + for pos = (set-marker + search-start + (previous-single-property-change search-start 'field)) + while (and (marker-position pos) + ;; FIXME: fragile (1- pos), use narrowing + (not (get-text-property (1- pos) 'sly-mrepl--prompt)) + (> pos (point-min))) + when (eq (field-at-pos pos) 'sly-mrepl--output) + do (let ((inhibit-read-only t)) + (delete-region (field-beginning pos) + (+ + (if (eq ?\n (char-before (field-end pos))) 0 1) + (field-end pos))) + (sly-mrepl--insert-output "; Cleared last output" + 'sly-mrepl-note-face)) + and return nil) + (sly-message "Cleared last output")) + +(defun sly-mrepl-next-prompt () + "Go to the beginning of the next REPL prompt." + (interactive) + (let ((pos (next-single-char-property-change (line-beginning-position 2) + 'sly-mrepl--prompt))) + (goto-char pos)) + (end-of-line)) + +(defun sly-mrepl-previous-prompt () + "Go to the beginning of the previous REPL prompt." + (interactive) + ;; This has two wrinkles around the first prompt: (1) when going to + ;; the first prompt it leaves point at column 0 (1) when called from + ;; frist prompt goes to beginning of buffer. The correct fix is to + ;; patch comint.el's comint-next-prompt and comint-previous-prompt + ;; anyway... + (let* ((inhibit-field-text-motion t) + (pos (previous-single-char-property-change (1- (line-beginning-position)) + 'sly-mrepl--prompt))) + (goto-char pos) + (goto-char (line-beginning-position))) + (end-of-line)) + + +;;; "External" non-interactive functions for plugging into +;;; other parts of SLY +;;; +(defun sly-inspector-copy-part-to-repl (number) + "Evaluate the inspector slot at point via the REPL (to set `*')." + (sly-mrepl--save-and-copy-for-repl + ;; FIXME: Using SLYNK:EVAL-FOR-INSPECTOR here repeats logic from + ;; sly.el's `sly-eval-for-inspector', but we can't use that here + ;; because we're already using `sly-mrepl--save-and-copy-for-repl'. + ;; Investigate if these functions could maybe be macros instead. + `(slynk:eval-for-inspector + ,sly--this-inspector-name + nil + 'slynk:inspector-nth-part-or-lose + ,number) + :before (format "Returning inspector slot %s" number))) + +(defun sly-db-copy-part-to-repl (frame-id var-id) + "Evaluate the frame var at point via the REPL (to set `*')." + (sly-mrepl--save-and-copy-for-repl + `(slynk-backend:frame-var-value ,frame-id ,var-id) + :repl (sly-mrepl--find-buffer (sly-current-connection) sly-current-thread) + :before (format "Returning var %s of frame %s" var-id frame-id))) + +(defun sly-apropos-copy-symbol-to-repl (name _type) + (sly-mrepl--save-and-copy-for-repl + `(common-lisp:identity ',(car (read-from-string name))) + :before (format "Returning symbol %s" name))) + +(defun sly-trace-dialog-copy-part-to-repl (id part-id type) + "Eval the Trace Dialog entry under point in the REPL (to set *)" + (sly-mrepl--save-and-copy-for-repl + `(slynk-trace-dialog:trace-part-or-lose ,id ,part-id ,type) + :before (format "Returning part %s (%s) of trace entry %s" part-id type id))) + +(defun sly-db-copy-call-to-repl (frame-id spec) + (sly-mrepl--save-and-copy-for-repl + `(slynk-backend:frame-arguments ,frame-id) + :before (format "The actual arguments passed to frame %s" frame-id) + :after #'(lambda (objects) + (sly-mrepl--insert-call spec objects)))) + +(defun sly-trace-dialog-copy-call-to-repl (trace-id spec) + (sly-mrepl--save-and-copy-for-repl + `(slynk-trace-dialog:trace-arguments-or-lose ,trace-id) + :before (format "The actual arguments passed to trace %s" trace-id) + :after #'(lambda (objects) + (sly-mrepl--insert-call spec objects)))) + +(defun sly-mrepl-inside-string-or-comment-p () + (let ((mark (and (process-live-p (sly-mrepl--process)) + (sly-mrepl--mark)))) + (when (and mark (> (point) mark)) + (let ((ppss (parse-partial-sexp mark (point)))) + (or (nth 3 ppss) (nth 4 ppss)))))) + + +;;; The comma shortcut +;;; +(defvar sly-mrepl-shortcut-history nil "History for sly-mrepl-shortcut.") + +(defun sly-mrepl-reset-shortcut (key-sequence) + "Set `sly-mrepl-shortcut' and reset REPL keymap accordingly." + (interactive "kNew shortcut key sequence? ") + (when (boundp 'sly-mrepl-shortcut) + (define-key sly-mrepl-mode-map sly-mrepl-shortcut nil)) + (set-default 'sly-mrepl-shortcut key-sequence) + (define-key sly-mrepl-mode-map key-sequence + '(menu-item "" sly-mrepl-shortcut + :filter (lambda (cmd) + (if (and (eq major-mode 'sly-mrepl-mode) + (sly-mrepl--shortcut-location-p)) + cmd))))) + +(defcustom sly-mrepl-shortcut (kbd ",") + "Keybinding string used for the REPL shortcut commands. +When setting this variable outside of the Customize interface, +`sly-mrepl-reset-shortcut' must be used." + :group 'sly + :type 'key-sequence + :set (lambda (_sym value) + (sly-mrepl-reset-shortcut value))) + +(defun sly-mrepl--shortcut-location-p () + (or (< (point) (sly-mrepl--mark)) + (and (not (let ((state (syntax-ppss))) + (or (nth 3 state) (nth 4 state)))) + (or (not (equal sly-mrepl-shortcut ",")) + (not (save-excursion + (search-backward "`" (sly-mrepl--mark) 'noerror))))))) + +(defvar sly-mrepl-shortcut-alist + ;; keep this alist ordered by the key value, in order to make it easier to see + ;; the identifying prefixes and keep them short + '(("cd" . sly-mrepl-set-directory) + ("clear repl" . sly-mrepl-clear-repl) + ("disconnect" . sly-disconnect) + ("disconnect all" . sly-disconnect-all) + ("in-package" . sly-mrepl-set-package) + ("restart lisp" . sly-restart-inferior-lisp) + ("quit lisp" . sly-quit-lisp) + ("sayoonara" . sly-quit-lisp) + ("set directory" . sly-mrepl-set-directory) + ("set package" . sly-mrepl-set-package))) + + +(defun sly-mrepl-set-package () + (interactive) + (let ((package (sly-read-package-name "New package: "))) + (sly-mrepl--eval-for-repl `(slynk-mrepl:guess-and-set-package ,package)))) + +(defun sly-mrepl-set-directory () + (interactive) + (let ((dir (read-directory-name "New directory: " + default-directory nil t))) + ;; repeats logic in `sly-cd'. + (sly-mrepl--eval-for-repl + `(slynk:set-default-directory + (slynk-backend:filename-to-pathname + ,(sly-to-lisp-filename dir)))) + (sly-mrepl--insert-note (format "Setting directory to %s" dir)) + (cd dir))) + +(advice-add + 'sly-cd :around + (lambda (oldfun r) + (interactive (lambda (oldspec) + (if (or (not (eq major-mode 'sly-mrepl-mode)) + (sly-y-or-n-p + (substitute-command-keys + "This won't set the REPL's directory (use \ + \\[sly-mrepl-set-directory] for that). Proceed?"))) + (list (advice-eval-interactive-spec oldspec)) + (keyboard-quit)))) + (apply oldfun r)) + '((name . sly-mrepl--be-aware-of-sly-cd))) + +(defun sly-mrepl-shortcut () + (interactive) + (let* ((string (completing-read "Command: " + (mapcar #'car sly-mrepl-shortcut-alist) + nil 'require-match nil + 'sly-mrepl-shortcut-history + (car sly-mrepl-shortcut-history))) + (command (and string + (cdr (assoc string sly-mrepl-shortcut-alist))))) + (call-interactively command))) + + +;;; Backreference highlighting +;;; +(defvar sly-mrepl--backreference-overlays nil + "List of overlays on top of REPL result buttons.") +(make-variable-buffer-local 'sly-mrepl--backreference-overlays) + +(defun sly-mrepl-highlight-results (&optional entry-idx value-idx) + "Highlight REPL results for ENTRY-IDX and VALUE-IDX. +If VALUE-IDX is nil or `all', highlight all results for entry +ENTRY-IDX. If ENTRY-IDX is nil, highlight all results. Returns +a list of result buttons thus highlighted" + (interactive) + (cl-loop + for button in (sly-button-buttons-in (point-min) (point-max)) + for e-idx = (car (button-get button 'part-args)) + for v-idx = (cadr (button-get button 'part-args)) + when (and (button-type-subtype-p (button-type button) 'sly-mrepl-part) + (eq (button-get button 'sly-connection) (sly-current-connection)) + (not (button-get button 'sly-mrepl--highlight-overlay)) + (and (or (not entry-idx) + (= e-idx entry-idx)) + (or (not value-idx) + (eq value-idx 'all) + (= v-idx value-idx)))) + collect button and + do (let ((overlay (make-overlay (button-start button) (button-end button)))) + (push overlay sly-mrepl--backreference-overlays) + (overlay-put overlay 'before-string + (concat + (propertize + (format "%s:%s" + (car (button-get button 'part-args)) + (cadr (button-get button 'part-args))) + 'face 'highlight) + " "))))) + +(defun sly-mrepl-unhighlight-results () + "Unhighlight all repl results" + (interactive) + (mapc #'delete-overlay sly-mrepl--backreference-overlays) + (setq sly-mrepl--backreference-overlays nil)) + +(defvar sly-mrepl--backreference-overlay nil) +(defvar sly-mrepl--backreference-prefix "#v") + +(defun sly-mrepl--highlight-backreferences-maybe () + "Intended to be placed in `post-command-hook'." + (sly-mrepl-unhighlight-results) + (when sly-mrepl--backreference-overlay + (delete-overlay sly-mrepl--backreference-overlay)) + (let* ((match (save-excursion + (sly-beginning-of-symbol) + (looking-at + (format "%s\\([[:digit:]]+\\)?\\(:\\([[:digit:]]+\\)\\|:\\)?" + sly-mrepl--backreference-prefix)))) + (m0 (and match (match-string 0))) + (m1 (and m0 (match-string 1))) + (m2 (and m1 (match-string 2))) + (m3 (and m2 (match-string 3))) + (entry-idx (and m1 (string-to-number m1))) + (value-idx (and match + (or (and m3 (string-to-number m3)) + (and (not m2) + 'all))))) + (if (null match) + (set (make-local-variable 'sly-autodoc-preamble) nil) + (let ((buttons (sly-mrepl-highlight-results entry-idx value-idx)) + (overlay + (or sly-mrepl--backreference-overlay + (set (make-local-variable 'sly-mrepl--backreference-overlay) + (make-overlay 0 0)))) + (message-log-max nil) + (message-text)) + (move-overlay sly-mrepl--backreference-overlay + (match-beginning 0) (match-end 0)) + (cond + ((null buttons) + (overlay-put overlay 'face 'font-lock-warning-face) + (setq message-text (format "No history references for backreference `%s'" m0))) + ((and buttons + entry-idx + value-idx) + (overlay-put overlay 'face 'sly-action-face) + (let* ((prefix (if (numberp value-idx) + (format "Matched history value %s of entry %s: " + value-idx + entry-idx) + (format "Matched history entry %s%s: " + entry-idx + (if (cl-rest buttons) + (format " (%s values)" (length buttons)) + "")))) + (hint (propertize + (truncate-string-to-width + (replace-regexp-in-string "\n" " " + (button-label + (cl-first buttons))) + (- (window-width (minibuffer-window)) + (length prefix) 10) + nil + nil + "...") + 'face + 'sly-action-face))) + (setq message-text (format "%s" (format "%s%s" prefix hint))))) + (buttons + (setq message-text (format "Ambiguous backreference `%s', %s values possible" + m0 (length buttons))) + (overlay-put overlay 'face 'font-lock-warning-face)) + (t + (overlay-put overlay 'face 'font-lock-warning-face) + (setq message-text (format "Invalid backreference `%s'" m0)))) + (sly-message "%s" message-text) + (set (make-local-variable 'sly-autodoc-preamble) message-text))))) + + +;;;; Menu +;;;; +(easy-menu-define sly-mrepl--shortcut-menu nil + "Menu for accessing the mREPL anywhere in sly." + (let* ((C '(sly-connected-p))) + `("mREPL" + ["Go to default REPL" sly-mrepl ,C] + ["New REPL" sly-mrepl-new ,C] + ["Sync Package & Directory" sly-mrepl-sync + (and sly-editing-mode ,C)]))) + +(easy-menu-add-item sly-menu nil sly-mrepl--shortcut-menu "Documentation") + +(easy-menu-define sly-mrepl--menu sly-mrepl-mode-map + "Menu for SLY's MREPL" + (let* ((C '(sly-connected-p))) + `("SLY-mREPL" + [ " Complete symbol at point " sly-mrepl-indent-and-complete-symbol ,C ] + [ " Interrupt " sly-interrupt ,C ] + [ " Isearch history backward " isearch-backward ,C] + "----" + [ " Clear REPL" sly-mrepl-clear-repl ,C ] + [ " Clear last output" sly-mrepl-clear-recent-output ,C ]))) + + +(defvar sly-mrepl--debug-overlays nil) + +(defun sly-mrepl--debug (&rest ignored) + (interactive) + (mapc #'delete-overlay sly-mrepl--debug-overlays) + (let ((overlay (make-overlay sly-mrepl--output-mark + (sly-mrepl--mark))) + (color (if (< sly-mrepl--output-mark (sly-mrepl--mark)) + "green" + "orange")) + (marker-color (if (= sly-mrepl--output-mark (sly-mrepl--mark)) + "red" + "purple"))) + (overlay-put overlay + 'face `(:background ,color)) + (overlay-put overlay + 'after-string (propertize "F" 'face + `(:background ,marker-color))) + (push overlay sly-mrepl--debug-overlays))) + +(defun sly-mrepl--turn-on-debug () + (interactive) + (add-hook 'after-change-functions 'sly-mrepl--debug nil 'local) + (add-hook 'post-command-hook 'sly-mrepl--debug nil 'local)) + +(defun sly-mrepl--turn-off-debug () + (interactive) + (remove-hook 'after-change-functions 'sly-mrepl--debug 'local) + (remove-hook 'post-command-hook 'sly-mrepl--debug 'local)) + + +;;; A hack for Emacs Bug#32014 (Sly gh#165) +;;; +(when (version<= "26.1" emacs-version) + (advice-add + #'lisp-indent-line + :around + (lambda (&rest args) + (let ((beg (save-excursion (progn (beginning-of-line) (point))))) + (cl-letf (((symbol-function #'indent-line-to) + (lambda (indent) + (let ((shift-amt (- indent (current-column)))) + (if (zerop shift-amt) + nil + (delete-region beg (point)) + (indent-to indent)))))) + ;; call original + (apply args)))) + '((name . sly-workaround-for-emacs-bug-32014)))) + + +;;; Sylvesters +;;; +(defvar sly-mrepl--sylvesters + (with-temp-buffer + (insert-file-contents-literally + (expand-file-name "sylvesters.txt" + (file-name-directory load-file-name))) + (cl-loop while (< (point) (point-max)) + for start = (point) + do (search-forward "\n\n" nil 'noerror) + collect (buffer-substring-no-properties start (- (point) 2))))) + +(defun sly-mrepl-random-sylvester () + (let* ((sylvester (nth (random (length sly-mrepl--sylvesters)) + sly-mrepl--sylvesters)) + (woe (sly-random-words-of-encouragement)) + (uncommented + (replace-regexp-in-string "@@@@" woe sylvester))) + uncommented)) + +(provide 'sly-mrepl) blob - /dev/null blob + 3ac8c05b128187744e0f26c9c93e355ea2da0ff5 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-package-fu.el @@ -0,0 +1,448 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'sly-parse "lib/sly-parse") + +(define-sly-contrib sly-package-fu + "Exporting/Unexporting symbols at point." + (:authors "Tobias C. Rittweiler ") + (:license "GPL") + (:slynk-dependencies slynk/package-fu) + (:on-load + (define-key sly-mode-map "\C-cx" 'sly-export-symbol-at-point) + (define-key sly-mode-map "\C-ci" 'sly-import-symbol-at-point)) + (:on-unload + ;; FIXME: To properly support unloading, this contrib should be + ;; made a minor mode with it's own keymap. The minor mode + ;; activation function should be added to the proper sly-* hooks. + ;; + )) + +(defvar sly-package-file-candidates + (mapcar #'file-name-nondirectory + '("package.lisp" "packages.lisp" "pkgdcl.lisp" + "defpackage.lisp"))) + +(defvar sly-export-symbol-representation-function + #'(lambda (n) (format "#:%s" n))) + +(defvar sly-import-symbol-package-transform-function + 'identity + "String transformation used by `sly-import-symbol-at-point'. + +This function is applied to a package name before it is inserted +into the defpackage form. By default, it is `identity' but you +may wish redefine it to do some tranformations, for example, to +replace dots with slashes to conform to a package-inferred ASDF +system-definition style.") + +(defvar sly-export-symbol-representation-auto t + "Determine automatically which style is used for symbols, #: or : +If it's mixed or no symbols are exported so far, +use `sly-export-symbol-representation-function'.") + +(define-obsolete-variable-alias 'sly-export-save-file + 'sly-package-fu-save-file "1.0.0-beta-3") + +(defvar sly-package-fu-save-file nil + "Save the package file after each automatic modification") + +(defvar sly-defpackage-regexp + "^(\\(cl:\\|common-lisp:\\|uiop:\\|\\uiop/package:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*") + +(put 'uiop:define-package 'sly-common-lisp-indent-function '(as defpackage)) + +(defun sly-find-package-definition-rpc (package) + (sly-eval `(slynk:find-definition-for-thing + (slynk::guess-package ,package)))) + +(defun sly-find-package-definition-regexp (package) + (save-excursion + (save-match-data + (goto-char (point-min)) + (cl-block nil + (while (re-search-forward sly-defpackage-regexp nil t) + (when (sly-package-equal package (sly-sexp-at-point)) + (backward-sexp) + (cl-return (make-sly-file-location (buffer-file-name) + (1- (point)))))))))) + +(defun sly-package-equal (designator1 designator2) + ;; First try to be lucky and compare the strings themselves (for the + ;; case when one of the designated packages isn't loaded in the + ;; image.) Then try to do it properly using the inferior Lisp which + ;; will also resolve nicknames for us &c. + (or (cl-equalp (sly-cl-symbol-name designator1) + (sly-cl-symbol-name designator2)) + (sly-eval `(slynk:package= ,designator1 ,designator2)))) + +(defun sly-export-symbol (symbol package) + "Unexport `symbol' from `package' in the Lisp image." + (sly-eval `(slynk:export-symbol-for-emacs ,symbol ,package))) + +(defun sly-unexport-symbol (symbol package) + "Export `symbol' from `package' in the Lisp image." + (sly-eval `(slynk:unexport-symbol-for-emacs ,symbol ,package))) + + +(defun sly-find-possible-package-file (buffer-file-name) + (cl-labels ((file-name-subdirectory (dirname) + (expand-file-name + (concat (file-name-as-directory (sly-to-lisp-filename dirname)) + (file-name-as-directory "..")))) + (try (dirname) + (cl-dolist (package-file-name sly-package-file-candidates) + (let ((f (sly-to-lisp-filename + (concat dirname package-file-name)))) + (when (file-readable-p f) + (cl-return f)))))) + (when buffer-file-name + (let ((buffer-cwd (file-name-directory buffer-file-name))) + (or (try buffer-cwd) + (try (file-name-subdirectory buffer-cwd)) + (try (file-name-subdirectory + (file-name-subdirectory buffer-cwd)))))))) + +(defun sly-goto-package-source-definition (package) + "Tries to find the DEFPACKAGE form of `package'. If found, +places the cursor at the start of the DEFPACKAGE form." + (cl-labels ((try (location) + (when (sly-location-p location) + (sly-move-to-source-location location) + t))) + (or (try (sly-find-package-definition-rpc package)) + (try (sly-find-package-definition-regexp package)) + (try (sly--when-let + (package-file (sly-find-possible-package-file + (buffer-file-name))) + (with-current-buffer (find-file-noselect package-file t) + (sly-find-package-definition-regexp package)))) + (sly-error "Couldn't find source definition of package: %s" package)))) + +(defun sly-at-expression-p (pattern) + (when (ignore-errors + ;; at a list? + (= (point) (progn (down-list 1) + (backward-up-list 1) + (point)))) + (save-excursion + (down-list 1) + (sly-in-expression-p pattern)))) + +(defun sly-goto-next-export-clause () + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (let ((point)) + (save-excursion + (cl-block nil + (while (ignore-errors (sly-forward-sexp) t) + (skip-chars-forward " \n\t") + (when (sly-at-expression-p '(:export *)) + (setq point (point)) + (cl-return))))) + (if point + (goto-char point) + (error "No next (:export ...) clause found")))) + +(defun sly-search-exports-in-defpackage (symbol-name) + "Look if `symbol-name' is mentioned in one of the :EXPORT clauses." + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (cl-labels ((target-symbol-p (symbol) + (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$" + (regexp-quote symbol-name)) + symbol))) + (save-excursion + (cl-block nil + (while (ignore-errors (sly-goto-next-export-clause) t) + (let ((clause-end (save-excursion (forward-sexp) (point)))) + (save-excursion + (while (search-forward symbol-name clause-end t) + (when (target-symbol-p (sly-symbol-at-point)) + (cl-return (if (sly-inside-string-p) + ;; Include the following " + (1+ (point)) + (point)))))))))))) + + +(defun sly-package-fu--read-symbols () + "Reads sexps as strings from the point to end of sexp. + +For example, in this situation. + + (for bar minor (again 123)) + +this will return (\"bar\" \"minor\" \"(again 123)\")" + (cl-labels ((read-sexp () + (ignore-errors + (forward-comment (point-max)) + (buffer-substring-no-properties + (point) (progn (forward-sexp) (point)))))) + (save-excursion + (cl-loop for sexp = (read-sexp) while sexp collect sexp)))) + +(defun sly-package-fu--normalize-name (name) + (if (string-prefix-p "\"" name) + (read name) + (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)" + "" name))) + +(defun sly-defpackage-exports () + "Return a list of symbols inside :export clause of a defpackage." + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (save-excursion + (mapcar #'sly-package-fu--normalize-name + (cl-loop while (ignore-errors (sly-goto-next-export-clause) t) + do (down-list) (forward-sexp) + append (sly-package-fu--read-symbols) + do (up-list) (backward-sexp))))) + +(defun sly-symbol-exported-p (name symbols) + (cl-member name symbols :test 'cl-equalp)) + +(defun sly-frob-defpackage-form (current-package do-what symbols) + "Adds/removes `symbol' from the DEFPACKAGE form of `current-package' +depending on the value of `do-what' which can either be `:export', +or `:unexport'. + +Returns t if the symbol was added/removed. Nil if the symbol was +already exported/unexported." + (save-excursion + (sly-goto-package-source-definition current-package) + (down-list 1) ; enter DEFPACKAGE form + (forward-sexp) ; skip DEFPACKAGE symbol + ;; Don't or will fail if (:export ...) is immediately following + ;; (forward-sexp) ; skip package name + (let ((exported-symbols (sly-defpackage-exports)) + (symbols (if (consp symbols) + symbols + (list symbols))) + (number-of-actions 0)) + (cl-ecase do-what + (:export + (sly-add-export) + (dolist (symbol symbols) + (let ((symbol-name (sly-cl-symbol-name symbol))) + (unless (sly-symbol-exported-p symbol-name exported-symbols) + (cl-incf number-of-actions) + (sly-package-fu--insert-symbol symbol-name))))) + (:unexport + (dolist (symbol symbols) + (let ((symbol-name (sly-cl-symbol-name symbol))) + (when (sly-symbol-exported-p symbol-name exported-symbols) + (sly-remove-export symbol-name) + (cl-incf number-of-actions)))))) + (when sly-package-fu-save-file + (save-buffer)) + (cons number-of-actions + (current-buffer))))) + +(defun sly-add-export () + (let (point) + (save-excursion + (while (ignore-errors (sly-goto-next-export-clause) t) + (setq point (point)))) + (cond (point + (goto-char point) + (down-list) + (sly-end-of-list)) + (t + (sly-end-of-list) + (unless (looking-back "^\\s-*" (line-beginning-position) nil) + (newline-and-indent)) + (insert "(:export ") + (save-excursion (insert ")")))))) + +(defun sly-determine-symbol-style () + ;; Assumes we're inside :export + (save-excursion + (sly-beginning-of-list) + (sly-forward-sexp) + (let ((symbols (sly-package-fu--read-symbols))) + (cond ((null symbols) + sly-export-symbol-representation-function) + ((cl-every (lambda (x) + (string-match "^:" x)) + symbols) + (lambda (n) (format ":%s" n))) + ((cl-every (lambda (x) + (string-match "^#:" x)) + symbols) + (lambda (n) (format "#:%s" n))) + ((cl-every (lambda (x) + (string-prefix-p "\"" x)) + symbols) + (lambda (n) (prin1-to-string (upcase (substring-no-properties n))))) + (t + sly-export-symbol-representation-function))))) + +(defun sly-format-symbol-for-defpackage (symbol-name) + (funcall (if sly-export-symbol-representation-auto + (sly-determine-symbol-style) + sly-export-symbol-representation-function) + symbol-name)) + +(defun sly-package-fu--insert-symbol (symbol-name) + ;; Assumes we're at the inside :export or :import-from form + ;; after the last symbol + (let ((symbol-name (sly-format-symbol-for-defpackage symbol-name))) + (unless (looking-back "^\\s-*" (line-beginning-position) nil) + (newline-and-indent)) + (insert symbol-name) + (when (looking-at "\\s_") (insert " ")))) + +(defun sly-remove-export (symbol-name) + ;; Assumes we're inside the beginning of a DEFPACKAGE form. + (let ((point)) + (while (setq point (sly-search-exports-in-defpackage symbol-name)) + (save-excursion + (goto-char point) + (backward-sexp) + (delete-region (point) point) + (beginning-of-line) + (when (looking-at "^\\s-*$") + (join-line) + (delete-trailing-whitespace (point) (line-end-position))))))) + +(defun sly-export-symbol-at-point () + "Add the symbol at point to the defpackage source definition +belonging to the current buffer-package. With prefix-arg, remove +the symbol again. Additionally performs an EXPORT/UNEXPORT of the +symbol in the Lisp image if possible." + (interactive) + (let* ((symbol (sly-symbol-at-point)) + (package (or (and (string-match "^\\([^:]+\\):.*" symbol) + (match-string 1 symbol)) + (sly-current-package)))) + (unless symbol (error "No symbol at point.")) + (cond (current-prefix-arg + (let* ((attempt (sly-frob-defpackage-form package :unexport symbol)) + (howmany (car attempt)) + (where (buffer-file-name (cdr attempt)))) + (if (cl-plusp howmany) + (sly-message "Symbol `%s' no longer exported from `%s' in %s" + symbol package where) + (sly-message "Symbol `%s' is not exported from `%s' in %s" + symbol package where))) + (sly-unexport-symbol symbol package)) + (t + (let* ((attempt (sly-frob-defpackage-form package :export symbol)) + (howmany (car attempt)) + (where (buffer-file-name (cdr attempt)))) + (if (cl-plusp howmany) + (sly-message "Symbol `%s' now exported from `%s' in %s" + symbol package where) + (sly-message "Symbol `%s' already exported from `%s' in %s" + symbol package where))) + (sly-export-symbol symbol package))))) + +(defun sly-export-class (name) + "Export acessors, constructors, etc. associated with a structure or a class" + (interactive (list (sly-read-from-minibuffer "Export structure named: " + (sly-symbol-at-point)))) + (let* ((package (sly-current-package)) + (symbols (sly-eval `(slynk:export-structure ,name ,package)))) + (sly-message "%s symbols exported from `%s'" + (car (sly-frob-defpackage-form package :export symbols)) + package))) + +(defalias 'sly-export-structure 'sly-export-class) + +;; +;; Dealing with import-from +;; + +(defun sly-package-fu--search-import-from (package) + (let* ((normalized-package (sly-package-fu--normalize-name package)) + (regexp (format "(:import-from[ \t']*\\(:\\|#:\\)?%s" + (regexp-quote normalized-package)))) + (re-search-forward regexp nil t))) + + +(defun sly-package-fu--create-new-import-from (package symbol) + "Add new :IMPORT-FROM subform for PACKAGE. Add SYMBOL. +Assumes point just before start of DEFPACKAGE form" + (forward-sexp) + ;; Now, search last :import-from or :use form + (cond + ((or (re-search-backward "(:\\(use\\|import-from\\)" nil t) + (and (re-search-backward "def[[:alnum:]]*package" nil t) + (progn (forward-sexp) t))) + ;; Skip found expression + (forward-sexp) + ;; and insert a new (:import-from ) form. + (newline-and-indent) + (let ((symbol-name (sly-format-symbol-for-defpackage symbol)) + (package-name (sly-format-symbol-for-defpackage package))) + (insert "(:import-from )") + (backward-char) + (insert package-name) + (newline-and-indent) + (insert symbol-name))) + (t (error "Can't find suitable place for :import-from defpackage form.")))) + + +(defun sly-package-fu--add-or-update-import-from-form (symbol) + "Do the heavy-lifting for `sly-import-symbol-at-point'. + +Accept a string or a symbol like \"alexandria:with-gensyms\", +and add it to existing (import-from #:alexandria ...) form, or +create a new one. Return name of the given symbol inside of its +package. For example above, return \"with-gensyms\"." + (let* ((package (or (funcall sly-import-symbol-package-transform-function + (sly-cl-symbol-package symbol)) + ;; We only process symbols in fully qualified form like + ;; weblocks/request:get-parameter + (user-error "`%s' is not a package-qualified symbol." + symbol))) + (simple-symbol (sly-cl-symbol-name symbol))) + (save-excursion + ;; First go to just before relevant DEFPACKAGE form + ;; + (sly-goto-package-source-definition (sly-current-package)) + + ;; Ask CL to actually import the symbol (a synchronized eval + ;; makes sure an error aborts the rest of the command) + ;; + (sly-eval `(slynk:import-symbol-for-emacs ,symbol + ,(sly-current-package) + ,package)) + (if (sly-package-fu--search-import-from package) + ;; If specific (:IMPORT-FROM PACKAGE... ) subform exists, + ;; attempt to insert package-less SYMBOL there. + (let ((imported-symbols (mapcar #'sly-package-fu--normalize-name + (sly-package-fu--read-symbols)))) + (unless (cl-member simple-symbol + imported-symbols + :test 'cl-equalp) + (sly-package-fu--insert-symbol simple-symbol) + (when sly-package-fu-save-file (save-buffer)))) + ;; Else, point is unmoved. Add a new (:IMPORT-FROM PACKAGE) + ;; subform after any other existing :IMPORT-FROM or :USE + ;; subforms. + (sly-package-fu--create-new-import-from package + simple-symbol) + (when sly-package-fu-save-file (save-buffer))) + ;; Always return symbol-without-package, because it is useful + ;; to replace symbol at point and change it from fully qualified + ;; form to a simple-form + simple-symbol))) + + +(defun sly-import-symbol-at-point () + "Add a qualified symbol to package's :import-from subclause. + +Takes a package-qualified symbol at point, adds it to the current +package's defpackage form (under its :import-form subclause) and +replaces with a symbol name without the package designator." + (interactive) + (let* ((bounds (sly-bounds-of-symbol-at-point)) + (beg (set-marker (make-marker) (car bounds))) + (end (set-marker (make-marker) (cdr bounds)))) + (when bounds + (let ((non-qualified-name + (sly-package-fu--add-or-update-import-from-form + (buffer-substring-no-properties beg end)))) + (when non-qualified-name + (delete-region beg end) + (insert non-qualified-name)))))) + + +(provide 'sly-package-fu) blob - /dev/null blob + 9b0a98ff5f520891af948804cb750437f70c687e (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-profiler.el @@ -0,0 +1,155 @@ +;;; -*- coding: utf-8; lexical-binding: t -*- +;;; +;;; sly-profiler.el -- a navigable dialog of inspectable timing entries +;;; +(eval-and-compile + (require 'sly) + (require 'sly-parse "lib/sly-parse")) + +(define-sly-contrib sly-profiler + "Provide an interfactive timing dialog buffer for managing and +inspecting details of timing functions. Invoke this dialog with C-c Y." + (:authors "João Távora ") + (:license "GPL") + (:slynk-dependencies slynk/profiler) + (:on-load (add-hook 'sly-mode-hook 'sly-profiler-enable)) + (:on-unload (remove-hook 'sly-mode-hook 'sly-profiler-enable))) + + +;;;; Modes and mode maps +;;; +(defvar sly-profiler-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "G") 'sly-profiler-fetch-timings) + (define-key map (kbd "C-k") 'sly-profiler-clear-fetched-timings) + (define-key map (kbd "g") 'sly-profiler-fetch-status) + (define-key map (kbd "q") 'quit-window) + map)) + +(define-derived-mode sly-profiler-mode fundamental-mode + "SLY Timing Dialog" "Mode for controlling SLY's Timing Dialog" + (set-syntax-table lisp-mode-syntax-table) + (read-only-mode 1)) + +(defvar sly-profiler-shortcut-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c Y") 'sly-profiler) + (define-key map (kbd "C-c C-y") 'sly-profiler-toggle-timing) + map)) + +(define-minor-mode sly-profiler-shortcut-mode + "Add keybindings for accessing SLY's Profiler.") + +(defun sly-profiler-enable () (sly-profiler-shortcut-mode 1)) + + +;;;; Helpers +;;; +(defun sly-profiler--get-buffer () + (let* ((name (format "*profiler for %s*" + (sly-connection-name sly-default-connection))) + (existing (get-buffer name))) + (cond ((and existing + (buffer-live-p existing) + (with-current-buffer existing + (memq sly-buffer-connection sly-net-processes))) + existing) + (t + (if existing (kill-buffer existing)) + (with-current-buffer (get-buffer-create name) + (sly-profiler-mode) + (setq sly-buffer-connection sly-default-connection) + (pop-to-buffer (current-buffer))))))) + +(defun sly-profiler--clear-local-tree () + (erase-buffer) + (insert "Cleared timings!")) + +(defun sly-profiler--render-timings (timing-specs) + (let ((inhibit-read-only t)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (cl-loop for spec in timing-specs + do (princ spec) (terpri))))) + +;;;; Interactive functions +;;; +;; (defun sly-profiler-fetch-specs () +;; "Refresh just list of timing specs." +;; (interactive) +;; (sly-eval-async `(slynk-profiler:report-specs) +;; #'sly-profiler--open-specs)) + +(defun sly-profiler-clear-fetched-timings (&optional interactive) + "Clear local and remote timings collected so far" + (interactive "p") + (when (or (not interactive) + (y-or-n-p "Clear all collected and fetched timings?")) + (sly-eval-async + '(slynk-profiler:clear-timing-tree) + #'sly-profiler--clear-local-tree))) + +(defun sly-profiler-fetch-timings () + (interactive) + (sly-eval-async `(slynk-profiler:report-latest-timings) + #'sly-profiler--render-timings)) + +(defun sly-profiler-fetch-status () + (interactive) + (sly-profiler-fetch-timings)) + +(defun sly-profiler-toggle-timing (&optional using-context-p) + "Toggle the dialog-timing of the spec at point. + +When USING-CONTEXT-P, attempt to decipher lambdas. methods and +other complicated function specs." + (interactive "P") + ;; Notice the use of "spec strings" here as opposed to the + ;; proper cons specs we use on the slynk side. + ;; + ;; Notice the conditional use of `sly-trace-query' found in + ;; slynk-fancy-trace.el + ;; + (let* ((spec-string (if using-context-p + (sly-extract-context) + (sly-symbol-at-point))) + (spec-string (read-from-minibuffer "(Un)time: " (format "%s" spec-string)))) + (message "%s" (sly-eval `(slynk-profiler:toggle-timing + (slynk::from-string ,spec-string)))))) + +(defun sly-profiler (&optional refresh) + "Show timing dialog and refresh timing collection status. + +With optional CLEAR-AND-FETCH prefix arg, clear the current tree +and fetch a first batch of timings." + (interactive "P") + (sly-with-popup-buffer ((sly-buffer-name :profiler :connection sly-default-connection) + :mode 'sly-profiler-mode + :select t) + (when refresh (sly-profiler-fetch-timings)))) + + +;;;; Menu +;;; +(easy-menu-define sly-profiler--shortcut-menu nil + "Menu setting traces from anywhere in SLY." + (let* ((in-dialog '(eq major-mode 'sly-profiler-mode)) + (_dialog-live `(and ,in-dialog + (memq sly-buffer-connection sly-net-processes))) + (connected '(sly-connected-p))) + `("Profiling" + ["(Un)Profile definition" sly-profiler-toggle-timing ,connected] + ["Open Profiler Dialog" sly-profiler (and ,connected (not ,in-dialog))]))) + +(easy-menu-add-item sly-menu nil sly-profiler--shortcut-menu "Documentation") + +(defvar sly-profiler--easy-menu + (let ((condition '(memq sly-buffer-connection sly-net-processes))) + `("Timing" + [ "Clear fetched timings" sly-profiler-clear-fetched-timings ,condition] + [ "Fetch timings" sly-profiler-fetch-timings ,condition]))) + +(easy-menu-define my-menu sly-profiler-mode-map "Timing" + sly-profiler--easy-menu) + +(provide 'sly-profiler) blob - /dev/null blob + 9ddf2378cf848ddb95d8945ee91801284c894cc7 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-retro.el @@ -0,0 +1,22 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) + +(define-sly-contrib sly-retro + "Enable SLIME to connect to a SLY-started SLYNK" + (:slynk-dependencies slynk/retro) + (:on-load (setq sly-net-send-translator #'sly-retro-slynk-to-swank)) + (:on-unload (setq sly-net-send-translator nil))) + +(defun sly-retro-slynk-to-swank (sexp) + (cond ((and sexp + (symbolp sexp) + (string-match "^slynk\\(.*\\)$" (symbol-name sexp))) + (intern (format "swank%s" (match-string 1 (symbol-name sexp))))) + ((and sexp (listp sexp)) + (cl-loop for (x . rest) on sexp + append (list (sly-retro-slynk-to-swank x)) into foo + finally (return (append foo (sly-retro-slynk-to-swank rest))))) + (t + sexp))) + +(provide 'sly-retro) blob - /dev/null blob + 4db0ca56846f5a0b62b39a6a2105656c73593809 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-scratch.el @@ -0,0 +1,45 @@ +;;; sly-scratch.el -*- lexical-binding: t; -*- + +(require 'sly) +(require 'cl-lib) + +(define-sly-contrib sly-scratch + "Imitate Emacs' *scratch* buffer" + (:authors "Helmut Eller ") + (:on-load + (define-key sly-selector-map (kbd "s") 'sly-scratch)) + (:license "GPL")) + + +;;; Code + +(defvar sly-scratch-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map lisp-mode-map) + (define-key map "\C-j" 'sly-eval-print-last-expression) + map)) + +(defun sly-scratch () + (interactive) + (sly-switch-to-scratch-buffer)) + +(defun sly-switch-to-scratch-buffer () + (set-buffer (sly-scratch-buffer)) + (unless (eq (current-buffer) (window-buffer)) + (pop-to-buffer (current-buffer) t))) + +(defvar sly-scratch-file nil) + +(defun sly-scratch-buffer () + "Return the scratch buffer, create it if necessary." + (or (get-buffer (sly-buffer-name :scratch)) + (with-current-buffer (if sly-scratch-file + (find-file sly-scratch-file) + (get-buffer-create (sly-buffer-name :scratch))) + (rename-buffer (sly-buffer-name :scratch)) + (lisp-mode) + (use-local-map sly-scratch-mode-map) + (sly-mode t) + (current-buffer)))) + +(provide 'sly-scratch) blob - /dev/null blob + bd58e4e3ec0a9cf0ce78f0dd69db3bad68791989 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-stickers.el @@ -0,0 +1,1359 @@ +;;; sly-stickers.el --- Live-code annotations for SLY -*- lexical-binding: t; -*- + +;; Copyright (C) 2014 João Távora + +;; Author: João Távora +;; Keywords: convenience, languages, lisp, tools + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: +;;; +;;; There is much in this library that would merit comment. Just some points: +;;; +;;; * Stickers are just overlays that exist on the Emacs side. A lot +;;; of the code is managing overlay nesting levels so that faces +;;; are chosen suitably for making sticker inside stickers +;;; visually recognizable. +;;; +;;; The main entry-point here is the interactive command +;;; `sly-sticker-dwim', which places and removes stickers. +;;; +;;; Stickers are also indexed by an integer and placed in a +;;; connection-global hash-table, `sly-stickers--stickers'. It can +;;; be connection-global because the same sticker with the same id +;;; might eventually be sent, multiple times, to many +;;; connections. It's the Slynk side that has to be able to tell +;;; whence the stickers comes from (this is not done currently). +;;; +;;; * The gist of stickers is instrumenting top-level forms. This is +;;; done by hooking onto `sly-compile-region-function'. Two separate +;;; compilations are performed: one for the uninstrumented form and +;;; another for the intrumented form. This is so that warnings and +;;; compilations errors that are due to stickers exclusively can be +;;; sorted out. If the second compilation fails, the stickers dont +;;; "stick", i.e. they are not armed. +;;; +;;; * File compilation is also hooked onto via +;;; `sly-compilation-finished-hook'. The idea here is to first +;;; compile the whole file, then traverse any top-level forms that +;;; contain stickers and instrument those. +;;; +;;; * On the emacs-side, the sticker overlays are very ephemeral +;;; objects. They are not persistently saved in any way. Deleting or +;;; modifying text inside them automatically deletes them. +;;; +;;; The slynk side eventually must be told to let go of deleted +;;; stickers. Before this happens these stickers are known as +;;; zombies. Reaping happens on almost every SLY -> Slynk call. +;;; Killing the buffer they live in doesn't automatically delete +;;; them, but reaping eventually happens anyway via +;;; `sly-stickers--sticker-by-id'. +;;; +;;; Before a zombie sticker is reaped, some code may still be +;;; running that adds recordings to these stickers, and some of +;;; these recordings make it to the Emacs side. The user can ignore +;;; them in `sly-stickers-replay', being notified that a deleted +;;; sticker is being referenced. +;;; +;;; This need to communicate dead stickers to Slynk is only here +;;; because using weak-hash-tables is impractical for stickers +;;; indexed by integers. Perhaps this could be fixed if the +;;; instrumented forms could reference sticker objects directly. +;;; +;;; * To see the results of sticker-instrumented code, there are the +;;; interactive commands `sly-stickers-replay' and +;;; `sly-stickers-fetch'. If "breaking stickers" is enabled, the +;;; debugger is also invoked before a sticker is reached and after a +;;; sticker returns (if it returns). Auxiliary data-structures like +;;; `sly-stickers--recording' are used here. +;;; +;;; * `sly-stickers--replay-state' and `sly-stickers--replay-map' are +;;; great big hacks just for handling the `sly-stickers-replay' +;;; interactive loop. Should look into recursive minibuffers or +;;; something more akin to `ediff', for example. +;;; +;;; Code: + + +(require 'sly) +(require 'sly-parse "lib/sly-parse") +(require 'sly-buttons "lib/sly-buttons") + +(eval-when-compile + (when (version< emacs-version "26") + ;; Using `cl-defstruct' needs `cl' on older Emacsen. See issue + ;; https://github.com/joaotavora/sly/issues/54 + (require 'cl))) + +(require 'cl-lib) +(require 'hi-lock) ; for the faces +(require 'color) +(require 'pulse) ; pulse-momentary-highlight-overlay + +(define-sly-contrib sly-stickers + "Mark expressions in source buffers and annotate return values." + (:authors "João Távora ") + (:license "GPL") + (:slynk-dependencies slynk/stickers) + (:on-load (add-hook 'sly-editing-mode-hook 'sly-stickers-mode) + (add-hook 'sly-mode-hook 'sly-stickers-shortcut-mode) + (setq sly-compile-region-function + 'sly-stickers-compile-region-aware-of-stickers) + (add-hook 'sly-compilation-finished-hook + 'sly-stickers-after-buffer-compilation t) + (add-hook 'sly-db-extras-hooks 'sly-stickers--handle-break)) + (:on-unload (remove-hook 'sly-editing-mode-hook 'sly-stickers-mode) + (remove-hook 'sly-mode-hook 'sly-stickers-shortcut-mode) + (setq sly-compile-region-function 'sly-compile-region-as-string) + (remove-hook 'sly-compilation-finished-hook + 'sly-stickers-after-buffer-compilation) + (remove-hook 'sly-db-extras-hooks 'sly-stickers--handle-break))) + + + +;;;; Bookeeping for local stickers +;;;; +(defvar sly-stickers--counter 0) + +(defvar sly-stickers--stickers (make-hash-table)) + +(defvar sly-stickers--zombie-sticker-ids nil + "Sticker ids that might exist in Slynk but no longer in Emacs.") + +(defun sly-stickers--zombies () sly-stickers--zombie-sticker-ids) + +(defun sly-stickers--reset-zombies () (setq sly-stickers--zombie-sticker-ids nil)) + + + +;;;; Sticker display and UI logic +;;;; +(defgroup sly-stickers nil + "Mark expressions in source buffers and annotate return values." + :prefix "sly-stickers-" + :group 'sly) + +(when nil + (cl-loop for sym in '(sly-stickers-placed-face + sly-stickers-armed-face + sly-stickers-empty-face + sly-stickers-recordings-face + sly-stickers-exited-non-locally-face) + do + (put sym 'face-defface-spec nil))) + +(defface sly-stickers-placed-face + '((((background dark)) (:background "light grey" :foreground "black")) + (t (:background "light grey"))) + "Face for sticker just set") + +(defface sly-stickers-armed-face + '((t (:strike-through nil :inherit hi-blue))) + "Face for stickers that have been armed") + +(defface sly-stickers-recordings-face + '((t (:strike-through nil :inherit hi-green))) + "Face for stickers that have new recordings") + +(defface sly-stickers-empty-face + '((t (:strike-through nil :inherit hi-pink))) + "Face for stickers that have no recordings.") + +(defface sly-stickers-exited-non-locally-face + '((t (:strike-through t :inherit sly-stickers-empty-face))) + "Face for stickers that have exited non-locally.") + +(defvar sly-stickers-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-s C-s") 'sly-stickers-dwim) + (define-key map (kbd "C-c C-s C-d") 'sly-stickers-clear-defun-stickers) + (define-key map (kbd "C-c C-s C-k") 'sly-stickers-clear-buffer-stickers) + map)) + +(defvar sly-stickers-shortcut-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-s S") 'sly-stickers-fetch) + (define-key map (kbd "C-c C-s F") 'sly-stickers-forget) + (define-key map (kbd "C-c C-s C-r") 'sly-stickers-replay) + map)) + +(define-minor-mode sly-stickers-mode + "Mark expression in source buffers and annotate return values.") + +(define-minor-mode sly-stickers-shortcut-mode + "Shortcuts for navigating sticker recordings.") + +(defvar sly-stickers--sticker-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-RET") 'sly-mrepl-copy-part-to-repl) + (define-key map [down-mouse-3] 'sly-button-popup-part-menu) + (define-key map [mouse-3] 'sly-button-popup-part-menu) + map)) + +(define-button-type 'sly-stickers-sticker :supertype 'sly-part + 'sly-button-inspect 'sly-stickers--inspect-recording + 'sly-button-echo 'sly-stickers--echo-sticker + 'keymap sly-stickers--sticker-map) + +(defun sly-stickers--set-tooltip (sticker &optional info) + (let* ((help-base (button-get sticker 'sly-stickers--base-help-echo)) + (text (if info + (concat "[sly] Sticker:" info "\n" help-base) + help-base))) + (button-put sticker 'help-echo text) + (button-put sticker 'sly-stickers--info info))) + +(defun sly-stickers--echo-sticker (sticker &rest more) + (cl-assert (null more) "Apparently two stickers at exact same location") + (sly-message (button-get sticker 'sly-stickers--info)) + (sly-button-flash sticker)) + +(defcustom sly-stickers-max-nested-stickers 4 + "The maximum expected level expected of sticker nesting. +If you nest more than this number of stickers inside other +stickers, the overlay face will be very dark, and probably +render the underlying text unreadable." + :type :integer) + +(defvar sly-stickers-color-face-attribute :background + "Color-capable attribute of sticker faces that represents nesting.") + +(gv-define-setter sly-stickers--level (level sticker) + `(prog1 + (setf (sly-button--level ,sticker) ,level) + (when (button-get ,sticker 'sly-stickers--base-face) + (sly-stickers--set-face ,sticker)))) + +(defun sly-stickers--level (sticker) (sly-button--level sticker)) + +(defun sly-stickers--guess-face-color (face) + (face-attribute-specified-or + (face-attribute face sly-stickers-color-face-attribute nil t) + nil)) + +(defun sly-stickers--set-face (sticker &optional face) + (let* ((face (or face + (button-get sticker 'sly-stickers--base-face))) + (guessed-color (sly-stickers--guess-face-color face))) + (button-put sticker 'sly-stickers--base-face face) + (unless guessed-color + (sly-error "sorry, can't guess color for face %s for sticker %s")) + (button-put sticker 'face + `(:inherit ,face + ,sly-stickers-color-face-attribute + ,(color-darken-name + guessed-color + (* 25 + (/ (sly-stickers--level sticker) + sly-stickers-max-nested-stickers + 1.0))))))) + +(defun sly-stickers--stickers-in (beg end) + (sly-button--overlays-in beg end 'sly-stickers--sticker-id)) +(defun sly-stickers--stickers-at (pos) + (sly-button--overlays-at pos 'sly-stickers--sticker-id)) +(defun sly-stickers--stickers-between (beg end) + (sly-button--overlays-between beg end 'sly-stickers--sticker-id)) +(defun sly-stickers--stickers-exactly-at (beg end) + (sly-button--overlays-exactly-at beg end 'sly-stickers--sticker-id)) + + +(defun sly-stickers--sticker (from to) + "Place a new sticker from FROM to TO" + (let* ((intersecting (sly-stickers--stickers-in from to)) + (contained (sly-stickers--stickers-between from to)) + (not-contained (cl-set-difference intersecting contained)) + (containers nil)) + (unless (cl-every #'(lambda (e) + (and (< (button-start e) from) + (> (button-end e) to))) + not-contained) + (sly-error "Cannot place a sticker that partially overlaps other stickers")) + (when (sly-stickers--stickers-exactly-at from to) + (sly-error "There is already a sticker at those very coordinates")) + ;; by now we know that other intersecting, non-contained stickers + ;; are our containers. + ;; + (setq containers not-contained) + (let* ((label "Brand new sticker") + (sticker + ;;; FIXME: We aren't using sly--make-text-button here + ;;; because it doesn't allow overlay button s + (make-button from to :type 'sly-stickers-sticker + 'sly-connection (sly-current-connection) + 'part-args (list -1 nil) + 'part-label label + 'sly-button-search-id (sly-button-next-search-id) + 'modification-hooks '(sly-stickers--sticker-modified) + 'sly-stickers-id (cl-incf sly-stickers--counter) + 'sly-stickers--base-help-echo + "mouse-3: Context menu"))) + ;; choose a suitable level for ourselves and increase the + ;; level of those contained by us + ;; + (setf (sly-stickers--level sticker) + (1+ (cl-reduce #'max containers + :key #'sly-stickers--level + :initial-value -1))) + (mapc (lambda (s) (cl-incf (sly-stickers--level s))) contained) + ;; finally, set face + ;; + (sly-stickers--set-tooltip sticker label) + (sly-stickers--set-face sticker 'sly-stickers-placed-face) + sticker))) + +(defun sly-stickers--sticker-id (sticker) + (button-get sticker 'sly-stickers-id)) + +(defun sly-stickers--arm-sticker (sticker) + (let* ((id (sly-stickers--sticker-id sticker)) + (label (format "Sticker %d is armed" id))) + (button-put sticker 'part-args (list id nil)) + (button-put sticker 'part-label label) + (button-put sticker 'sly-stickers--last-known-recording nil) + (sly-stickers--set-tooltip sticker label) + (sly-stickers--set-face sticker 'sly-stickers-armed-face) + (puthash id sticker sly-stickers--stickers))) + +(defun sly-stickers--disarm-sticker (sticker) + (let* ((id (sly-stickers--sticker-id sticker)) + (label (format "Sticker %d failed to stick" id))) + (button-put sticker 'part-args (list -1 nil)) + (button-put sticker 'part-label label) + (sly-stickers--set-tooltip sticker label) + (sly-stickers--set-face sticker 'sly-stickers-placed-face))) + +(define-button-type 'sly-stickers--recording-part :supertype 'sly-part + 'sly-button-inspect + 'sly-stickers--inspect-recording + ;; 'sly-button-pretty-print + ;; #'(lambda (id) ...) + ;; 'sly-button-describe + ;; #'(lambda (id) ...) + ;; 'sly-button-show-source + ;; #'(lambda (id) ...) + ) + +(defun sly-stickers--recording-part (label sticker-id recording vindex + &rest props) + (apply #'sly--make-text-button + label nil + :type 'sly-stickers--recording-part + 'part-args (list sticker-id recording vindex) + 'part-label "Recorded value" + props)) + +(cl-defun sly-stickers--describe-recording-values (recording &key + (indent 0) + (prefix "=> ")) + (cl-flet ((indent (str) + (concat (make-string indent ? )str)) + (prefix (str) + (concat prefix str))) + (let ((descs (sly-stickers--recording-value-descriptions recording))) + (cond ((sly-stickers--recording-exited-non-locally-p recording) + (indent (propertize "exited non locally" 'face 'sly-action-face))) + ((null descs) + (indent (propertize "no values" 'face 'sly-action-face))) + (t + (cl-loop for (value-desc . rest) on descs + for vindex from 0 + concat + (indent (prefix + (sly-stickers--recording-part + value-desc + (sly-stickers--recording-sticker-id recording) + recording + vindex))) + when rest + concat "\n")))))) + +(defconst sly-stickers--newline "\n" + "Work around bug #63, actually Emacs bug #21839. +\"25.0.50; can't use newlines in defaults in cl functions\"") + +(cl-defun sly-stickers--pretty-describe-recording + (recording &key (separator sly-stickers--newline)) + (let* ((recording-sticker-id (sly-stickers--recording-sticker-id recording)) + (sticker (gethash recording-sticker-id + sly-stickers--stickers)) + (nvalues (length (sly-stickers--recording-value-descriptions recording)))) + (format "%s%s:%s%s" + (if sticker + (format "Sticker %s on line %s of %s" + (sly-stickers--sticker-id sticker) + (with-current-buffer (overlay-buffer sticker) + (line-number-at-pos (overlay-start sticker))) + (overlay-buffer sticker)) + (format "Deleted or unknown sticker %s" + recording-sticker-id)) + (if (cl-plusp nvalues) + (format " returned %s values" nvalues) "") + separator + (sly-stickers--describe-recording-values recording + :indent 2)))) + +(defun sly-stickers--populate-sticker (sticker recording) + (let* ((id (sly-stickers--sticker-id sticker)) + (total (sly-stickers--recording-sticker-total recording))) + (cond ((cl-plusp total) + (button-put sticker 'part-label + (format "Sticker %d has %d recordings" id total)) + (unless (sly-stickers--recording-void-p recording) + (button-put sticker 'sly-stickers--last-known-recording recording) + (button-put sticker 'part-args (list id recording)) + (sly-stickers--set-tooltip + sticker + (format "Newest of %s sticker recordings:\n%s" + total + (sly-stickers--describe-recording-values recording :prefix ""))) + (sly-stickers--set-face + sticker + (if (sly-stickers--recording-exited-non-locally-p recording) + 'sly-stickers-exited-non-locally-face + 'sly-stickers-recordings-face)))) + (t + (let ((last-known-recording + (button-get sticker 'sly-stickers--last-known-recording))) + (button-put sticker 'part-label + (format "Sticker %d has no recordings" id)) + (when last-known-recording + (sly-stickers--set-tooltip + sticker + (format "No new recordings. Last known:\n%s" + (sly-stickers--describe-recording-values + last-known-recording)))) + (sly-stickers--set-tooltip sticker "No new recordings") + (sly-stickers--set-face sticker 'sly-stickers-empty-face)))))) + +(defun sly-stickers--sticker-substickers (sticker) + (let* ((retval + (remove sticker + (sly-stickers--stickers-between (button-start sticker) + (button-end sticker)))) + ;; To verify an important invariant, and warn (don't crash) + ;; + (exactly-at + (sly-stickers--stickers-exactly-at (button-start sticker) + (button-end sticker)))) + (cond + ((remove sticker exactly-at) + (sly-warning "Something's fishy. More than one sticker at same position") + (cl-set-difference retval exactly-at)) + (t + retval)))) + +(defun sly-stickers--briefly-describe-sticker (sticker) + (let ((beg (button-start sticker)) + (end (button-end sticker))) + (if (< (- end beg) 20) + (format "sticker around %s" (buffer-substring-no-properties beg end)) + (cl-labels ((word (point direction) + (apply #'buffer-substring-no-properties + (sort (list + point + (save-excursion (goto-char point) + (forward-word direction) + (point))) + #'<)))) + (format "sticker from \"%s...\" to \"...%s\"" + (word beg 1) + (word end -1)))))) + +(defun sly-stickers--delete (sticker) + "Ensure that sticker is deleted." + ;; Delete the overlay and take care of levels for contained and + ;; containers, but note that a sticker might have no buffer anymore + ;; if that buffer was killed, for example... + ;; + (when (and (overlay-buffer sticker) + (buffer-live-p (overlay-buffer sticker))) + (mapc (lambda (s) (cl-decf (sly-stickers--level s))) + (sly-stickers--sticker-substickers sticker)) + (delete-overlay sticker)) + ;; We also want to deregister it from the hashtable in case it's + ;; there (it's not there if it has never been armed) + ;; + (let ((id (sly-stickers--sticker-id sticker))) + (when (gethash (sly-stickers--sticker-id sticker) + sly-stickers--stickers) + (remhash id sly-stickers--stickers) + (add-to-list 'sly-stickers--zombie-sticker-ids id)))) + +(defun sly-stickers--sticker-modified (sticker _after? beg end + &optional _pre-change-len) + (unless (save-excursion + (goto-char beg) + (skip-chars-forward "\t\n\s") + (>= (point) end)) + (let ((inhibit-modification-hooks t)) + (sly-message "Deleting %s" + (sly-stickers--briefly-describe-sticker sticker)) + (sly-stickers--delete sticker)))) + +(defun sly-stickers-next-sticker (&optional n) + (interactive "p") + (sly-button-search n 'sly-stickers--sticker-id)) + +(defun sly-stickers-prev-sticker (&optional n) + (interactive "p") + (sly-button-search (- n) 'sly-stickers--sticker-id)) + +(put 'sly-stickers-next-sticker 'sly-button-navigation-command t) +(put 'sly-stickers-prev-sticker 'sly-button-navigation-command t) + +(defun sly-stickers-clear-defun-stickers () + "Clear all stickers in the current top-level form." + (interactive) + (let* ((region (sly-region-for-defun-at-point))) + (sly-stickers-clear-region-stickers (car region) (cadr region)))) + +(defun sly-stickers-clear-buffer-stickers () + "Clear all the stickers in the current buffer." + (interactive) + (sly-stickers-clear-region-stickers (point-min) (point-max))) + +(defun sly-stickers-clear-region-stickers (&optional from to) + "Clear all the stickers between FROM and TO." + (interactive "r") + (let* ((from (or from (region-beginning))) + (to (or to (region-end))) + (stickers (sly-stickers--stickers-in from to))) + (cond (stickers + (mapc #'sly-stickers--delete stickers) + (sly-message "%s stickers cleared" (length stickers))) + (t + (sly-message "no stickers to clear"))))) + +(defun sly-stickers-delete-sticker-at-point (&optional point) + "Delete the topmost sticker at point." + (interactive "d") + (let ((stickers (sly-stickers--stickers-at (or point (point))))) + (cond + (stickers + (sly-stickers--delete (car stickers)) + (if (cdr stickers) + (sly-message "Deleted topmost sticker (%d remain at point)" + (length (cdr stickers))) + (sly-message "Deleted sticker %s" + (sly-stickers--briefly-describe-sticker (car stickers))))) + (t + (sly-user-error "No stickers at point"))))) + +(defun sly-stickers-maybe-add-sticker (&optional point) + "Add of remove a sticker at POINT. +If point is currently at a sticker boundary, delete that sticker, +otherwise, add a sticker to the sexp at point." + (interactive "d") + (save-excursion + (goto-char (or point (point))) + (let* ((bounds (sly-bounds-of-sexp-at-point)) + (beg (car bounds)) + (end (cdr bounds)) + (matching (and bounds + (sly-stickers--stickers-exactly-at beg end)))) + (cond + ((not bounds) + (sly-message "Nothing here to place sticker on, apparently")) + (matching + (sly-stickers--delete (car matching)) + (sly-message "Deleted sticker")) + (t + (let ((sticker (sly-stickers--sticker beg end))) + (sly-message "Added %s" + (sly-stickers--briefly-describe-sticker sticker)))))))) + +(defun sly-stickers-dwim (prefix) + "Set or remove stickers at point. +Set a sticker for the current sexp at point, or delete it if it +already exists. + +If the region is active set a sticker in the current region. + +With interactive prefix arg PREFIX always delete stickers. + +- One C-u means delete the current top-level form's stickers. +- Two C-u's means delete the current buffer's stickers" + (interactive "p") + (cond + ((= prefix 4) + (if (region-active-p) + (sly-stickers-clear-region-stickers) + (sly-stickers-clear-defun-stickers))) + ((>= prefix 16) + (sly-stickers-clear-buffer-stickers)) + ((region-active-p) + (sly-stickers--sticker (region-beginning) (region-end)) + (deactivate-mark t)) + ((not (sly-inside-string-or-comment-p)) + (sly-stickers-maybe-add-sticker)) + (t + (sly-message "No point placing stickers in string literals or comments")))) + +(defun sly-stickers--sticker-by-id (sticker-id) + "Return the sticker for STICKER-ID, or return NIL. +Perform some housecleaning tasks for stickers that have been +properly deleted or brutally killed with the buffer they were in." + (let* ((sticker (gethash sticker-id sly-stickers--stickers))) + (cond ((and sticker (overlay-buffer sticker) + (buffer-live-p (overlay-buffer sticker))) + sticker) + (sticker + ;; `sticker-id' references a sticker that hasn't been + ;; deleted but whose overlay can't be found. One reason for + ;; this is that the buffer it existed in was killed. So + ;; delete it now and mark it a zombie. + (sly-stickers--delete sticker) + nil) + (t + ;; The sticker isn't in the `sly-stickers--stickers' hash + ;; table, so it has probably already been marked zombie, + ;; and possibly already deleted. We're probably just seeing + ;; it because recording playback and breaking stickers may + ;; not filtering these out by user option. + ;; + ;; To be on the safe side, add the id to the table anyway, + ;; so it'll get killed on the Slynk side on the next + ;; request. + ;; + (add-to-list 'sly-stickers--zombie-sticker-ids sticker-id) + nil)))) + +(defvar sly-stickers--flashing-sticker nil + "The sticker currently being flashed.") + +(cl-defun sly-stickers--find-and-flash (sticker-id &key (otherwise nil)) + "Find and flash the sticker referenced by STICKER-ID. +otherwise call OTHERWISE with a single argument, a string stating +the reason why the sticker couldn't be found" + (let ((sticker (sly-stickers--sticker-by-id sticker-id))) + (cond (sticker + (let ((buffer (overlay-buffer sticker))) + (when buffer + (with-current-buffer buffer + (let* ((window (display-buffer buffer t))) + (when window + (with-selected-window window + (push-mark nil t) + (goto-char (overlay-start sticker)) + (sly-recenter (point)) + (setq sly-stickers--flashing-sticker sticker) + (pulse-momentary-highlight-overlay sticker 'highlight) + (run-with-timer + 2 nil + (lambda () + (when (eq sly-stickers--flashing-sticker sticker) + (pulse-momentary-highlight-overlay + sticker 'highlight))))))))))) + (otherwise + (funcall otherwise "Can't find sticker (probably deleted!)"))))) + +;; Work around an Emacs bug, probably won't be needed in Emacs 27.1 +(advice-add 'pulse-momentary-unhighlight + :before (lambda (&rest _args) + (let ((o pulse-momentary-overlay)) + (when (and o (overlay-get o 'sly-stickers-id)) + (overlay-put o 'priority nil)))) + '((name . fix-pulse-momentary-unhighlight-bug))) + + +;;;; Recordings +;;;; +(cl-defstruct (sly-stickers--recording + (:constructor sly-stickers--make-recording-1) + (:conc-name sly-stickers--recording-) + (:copier sly-stickers--copy-recording)) + (sticker-id nil) + (sticker-total nil) + (id nil) + (value-descriptions nil) + (exited-non-locally-p nil) + (sly-connection nil)) + +(defun sly-stickers--recording-void-p (recording) + (not (sly-stickers--recording-id recording))) + +(defun sly-stickers--make-recording (description) + "Make a `sly-stickers--recording' from DESCRIPTION. +A DESCRIPTION is how the Lisp side describes a sticker and +usually its most recent recording. If it doesn't, a recording +veryfying `sly-stickers--recording-void-p' is created." + (cl-destructuring-bind (sticker-id sticker-total . recording-description) + description + (let ((recording (sly-stickers--make-recording-1 + :sticker-id sticker-id + :sticker-total sticker-total + :sly-connection (sly-current-connection)))) + (when recording-description + (cl-destructuring-bind (recording-id _recording-ctime + value-descriptions + exited-non-locally-p) + recording-description + (setf + (sly-stickers--recording-id recording) + recording-id + (sly-stickers--recording-value-descriptions recording) + value-descriptions + (sly-stickers--recording-exited-non-locally-p recording) + exited-non-locally-p))) + recording))) + + +;;;; Replaying sticker recordings +;;;; +(defvar sly-stickers--replay-help nil) + +(defvar sly-stickers--replay-mode-map + (let ((map (make-sparse-keymap))) + (cl-flet + ((def + (key binding &optional desc) + (define-key map (kbd key) binding) + (setf + (cl-getf sly-stickers--replay-help binding) + (cons (cons key (car (cl-getf sly-stickers--replay-help binding))) + (or desc + (cdr (cl-getf sly-stickers--replay-help binding))))))) + (def "n" 'sly-stickers-replay-next + "Scan recordings forward") + (def "SPC" 'sly-stickers-replay-next) + (def "N" 'sly-stickers-replay-next-for-sticker + "Scan recordings forward for this sticker") + (def "DEL" 'sly-stickers-replay-prev + "Scan recordings backward") + (def "p" 'sly-stickers-replay-prev) + (def "P" 'sly-stickers-replay-prev-for-sticker + "Scan recordings backward for this sticker") + (def "j" 'sly-stickers-replay-jump + "Jump to a recording") + (def ">" 'sly-stickers-replay-jump-to-end + "Go to last recording") + (def "<" 'sly-stickers-replay-jump-to-beginning + "Go to first recording") + (def "h" 'sly-stickers-replay-toggle-help + "Toggle help") + (def "v" 'sly-stickers-replay-pop-to-current-sticker + "Pop to current sticker") + (def "V" 'sly-stickers-replay-toggle-pop-to-stickers + "Toggle popping to stickers") + (def "q" 'quit-window + "Quit") + (def "x" 'sly-stickers-replay-toggle-ignore-sticker + "Toggle ignoring a sticker") + (def "z" 'sly-stickers-replay-toggle-ignore-zombies + "Toggle ignoring deleted stickers") + (def "R" 'sly-stickers-replay-reset-ignore-list + "Reset ignore list") + (def "F" 'sly-stickers-forget + "Forget about sticker recordings") + (def "g" 'sly-stickers-replay-refresh + "Refresh current recording") + map))) + +(define-derived-mode sly-stickers--replay-mode fundamental-mode + "SLY Stickers Replay" "Mode for controlling sticker replay sessions Dialog" + (set-syntax-table lisp-mode-syntax-table) + (read-only-mode 1) + (sly-mode 1) + (add-hook 'post-command-hook + 'sly-stickers--replay-postch t t)) + +(defun sly-stickers--replay-postch () + (let ((win (get-buffer-window (current-buffer)))) + (when (and win + (window-live-p win)) + (ignore-errors + (set-window-text-height win (line-number-at-pos (point-max))))))) + +(defvar sly-stickers--replay-expanded-help nil) + +(defun sly-stickers-replay-toggle-help () + (interactive) + (set (make-local-variable 'sly-stickers--replay-expanded-help) + (not sly-stickers--replay-expanded-help)) + (sly-stickers--replay-refresh-1)) + +(sly-def-connection-var sly-stickers--replay-data nil + "Data structure for information related to recordings") + +(defvar sly-stickers--replay-key nil + "A symbol identifying a particular replaying session in the + Slynk server.") + +(defvar sly-stickers--replay-pop-to-stickers t) + +(defun sly-stickers--replay-refresh-1 () + "Insert a description of the current recording into the current +buffer" + (cl-assert (eq major-mode 'sly-stickers--replay-mode) + nil + "%s must be run in a stickers replay buffer" + this-command) + (cl-labels + ((paragraph () (if sly-stickers--replay-expanded-help "\n\n" "\n")) + (describe-ignored-stickers + () + (let ((ignored-ids (cl-getf (sly-stickers--replay-data) + :ignored-ids)) + (ignore-zombies-p (cl-getf (sly-stickers--replay-data) + :ignore-zombies-p))) + (if (or ignored-ids ignore-zombies-p) + (format "%s%s%s" + (paragraph) + (if ignore-zombies-p + "Skipping recordings of deleted stickers. " "") + (if ignored-ids + (format "Skipping recordings of sticker%s %s." + (if (cl-rest ignored-ids) "s" "") + (concat (mapconcat #'pp-to-string + (butlast ignored-ids) + ", ") + (and (cl-rest ignored-ids) " and ") + (pp-to-string + (car (last ignored-ids))))) + "")) + ""))) + (describe-help + () + (format "%s%s" + (paragraph) + (if sly-stickers--replay-expanded-help + (substitute-command-keys "\\{sly-stickers--replay-mode-map}") + "n => next, p => previous, x => ignore, h => help, q => quit"))) + (describe-number-of-recordings + (new-total) + (let* ((old-total (cl-getf (sly-stickers--replay-data) :old-total)) + (diff (and old-total (- new-total old-total)))) + (format "%s total recordings%s" + new-total + (cond ((and diff + (cl-plusp diff)) + (propertize (format ", %s new in the meantime" + diff) + 'face 'bold)) + (t + ""))))) + (describe-playhead + (recording) + (let ((new-total (cl-getf (sly-stickers--replay-data) :total)) + (index (cl-getf (sly-stickers--replay-data) :index))) + (cond + ((and new-total + recording) + (format "Playhead at recording %s of %s" + (ignore-errors (1+ index)) + (describe-number-of-recordings new-total))) + (new-total + (format "Playhead detached (ignoring too many stickers?) on %s" + (describe-number-of-recordings new-total))) + (recording + (substitute-command-keys + "Playhead confused (perhaps hit \\[sly-stickers-replay-refresh])")) + (t + (format + "No recordings! Perhaps you need to run some sticker-aware code first")))))) + (sly-refreshing () + (let ((rec (cl-getf (sly-stickers--replay-data) :recording))) + (insert (describe-playhead rec) (paragraph)) + (when rec + (insert (sly-stickers--pretty-describe-recording + rec + :separator (paragraph))))) + (insert (describe-ignored-stickers)) + (insert (describe-help))))) + +(defun sly-stickers-replay () + "Start interactive replaying of known sticker recordings." + (interactive) + (let* ((buffer-name (sly-buffer-name :stickers-replay + :connection (sly-current-connection))) + (existing-buffer (get-buffer buffer-name))) + (let ((split-width-threshold nil) + (split-height-threshold 0)) + (sly-with-popup-buffer (buffer-name + :mode 'sly-stickers--replay-mode + :select t) + (setq existing-buffer standard-output))) + (with-current-buffer existing-buffer + (setf (cl-getf (sly-stickers--replay-data) :replay-key) + (cl-gensym "stickers-replay-")) + (let ((old-total (cl-getf (sly-stickers--replay-data) :total)) + (new-total (sly-eval '(slynk-stickers:total-recordings)))) + (setf (cl-getf (sly-stickers--replay-data) :old-total) old-total) + (when (and + old-total + (cl-plusp old-total) + (> new-total old-total) + (sly-y-or-n-p + "Looks like there are %s new recordings since last replay.\n +Forget about old ones before continuing?" (- new-total old-total))) + (sly-stickers-forget old-total))) + + (sly-stickers-replay-refresh 0 + (if existing-buffer nil t) + t) + (set-window-dedicated-p nil 'soft) + (with-current-buffer existing-buffer + (sly-stickers--replay-postch))))) + +(defun sly-stickers-replay-refresh (n command &optional interactive) + "Refresh the current sticker replay session. +N and COMMAND are passed to the Slynk server and instruct what +recording to fetch: + +If COMMAND is nil, navigate to Nth next sticker recording, +skipping ignored stickers. + +If COMMAND is a number, navigate to the Nth next sticker +recording for the sticker with that numeric sticker id. + +If COMMAND is any other value, jump directly to the recording +index N. + +Interactively, N is 0 and and COMMAND is nil, meaning that the +playhead should stay put and the buffer should be refreshed. + +Non-interactively signal an error if no recording was fetched and +INTERACTIVE is the symbol `sly-error'. + +Non-interactively, set the `:recording' slot of +`sly-stickers--replay-data' to nil if no recording was fetched." + (interactive (list 0 nil t)) + (let ((result (sly-eval + `(slynk-stickers:search-for-recording + ',(cl-getf (sly-stickers--replay-data) :replay-key) + ',(cl-getf (sly-stickers--replay-data) :ignored-ids) + ',(cl-getf (sly-stickers--replay-data) :ignore-zombies-p) + ',(sly-stickers--zombies) + ,n + ',command)))) + ;; presumably, Slynk cleaned up the zombies we passed it. + ;; + (sly-stickers--reset-zombies) + (cond ((car result) + (cl-destructuring-bind (total index &rest sticker-description) + result + (let ((rec (sly-stickers--make-recording sticker-description)) + (old-index (cl-getf (sly-stickers--replay-data) :index))) + (setf (cl-getf (sly-stickers--replay-data) :index) index + (cl-getf (sly-stickers--replay-data) :total) total + (cl-getf (sly-stickers--replay-data) :recording) rec) + (if old-index + (if (cl-plusp n) + (if (> old-index index) (sly-message "Rolled over to start")) + (if (< old-index index) (sly-message "Rolled over to end")))) + ;; Assert that the recording isn't void + ;; + (when (sly-stickers--recording-void-p rec) + (sly-error "Attempt to visit a void recording described by %s" + sticker-description)) + (when sly-stickers--replay-pop-to-stickers + (sly-stickers--find-and-flash + (sly-stickers--recording-sticker-id rec)))))) + (interactive + ;; If we were called interactively and got an error, it's + ;; probably because there aren't any recordings, so reset + ;; data + ;; + (setf (sly-stickers--replay-data) nil) + (when (eq interactive 'sly-error) + (sly-error "%s for %s reported an error: %s" + 'slynk-stickers:search-for-recording + n + (cadr result))) + (setf (cl-getf (sly-stickers--replay-data) :recording) nil))) + (if interactive + (sly-stickers--replay-refresh-1) + (cl-getf (sly-stickers--replay-data) :recording )))) + +(defun sly-stickers-replay-next (n) + "Navigate to Nth next sticker recording, skipping ignored stickers" + (interactive "p") + (sly-stickers-replay-refresh n nil 'sly-error)) + +(defun sly-stickers-replay-prev (n) + "Navigate to Nth prev sticker recording, skipping ignored stickers" + (interactive "p") + (sly-stickers-replay-refresh (- n) nil 'sly-error)) + +(defun sly-stickers-replay--current-sticker-interactive (prompt) + (if current-prefix-arg + (read-number (format "[sly] %s " prompt)) + (sly-stickers--recording-sticker-id + (cl-getf (sly-stickers--replay-data) :recording)))) + +(defun sly-stickers-replay-next-for-sticker (n sticker-id) + "Navigate to Nth next sticker recording for STICKER-ID" + (interactive (list + (if (numberp current-prefix-arg) + current-prefix-arg + 1) + (sly-stickers-replay--current-sticker-interactive + "Which sticker?"))) + (sly-stickers-replay-refresh n sticker-id 'sly-error)) + +(defun sly-stickers-replay-prev-for-sticker (n sticker-id) + "Navigate to Nth prev sticker recording for STICKER-ID" + (interactive (list + (- (if (numberp current-prefix-arg) + current-prefix-arg + 1)) + (sly-stickers-replay--current-sticker-interactive + "Which sticker?"))) + (sly-stickers-replay-refresh n sticker-id 'sly-error)) + +(defun sly-stickers-replay-jump (n) + "Fetch and jump to Nth sticker recording" + (interactive (read-number "[sly] jump to which recording? ")) + (sly-stickers-replay-refresh n 'absolute-p 'sly-error)) + +(defun sly-stickers-replay-jump-to-beginning () + "Fetch and jump to the first sticker recording" + (interactive) + (sly-stickers-replay-refresh 0 'absolute-p 'sly-error)) + +(defun sly-stickers-replay-jump-to-end () + "Fetch and jump to the last sticker recording" + (interactive) + (sly-stickers-replay-refresh -1 'absolute-p 'sly-error)) + +(defun sly-stickers-replay-toggle-ignore-sticker (sticker-id) + "Toggle ignoring recordings of sticker with STICKER-ID" + (interactive (list + (sly-stickers-replay--current-sticker-interactive + "Toggle ignoring which sticker id?"))) + (let* ((ignored (cl-getf (sly-stickers--replay-data) :ignored-ids)) + (ignored-p (memq sticker-id ignored))) + (cond (ignored-p + (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) + (delq sticker-id (cdr ignored))) + (sly-message "No longer ignoring sticker %s" sticker-id)) + (t + (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) + (delete-dups ; stupid but safe + (cons sticker-id ignored))) + (sly-message "Now ignoring sticker %s" sticker-id))) + (sly-stickers-replay-refresh (if ignored-p ; was ignored, now isn't + 0 + 1) + nil + t))) + +(defun sly-stickers-replay-toggle-ignore-zombies () + "Toggle ignoring recordings of zombie stickers." + (interactive) + (let ((switch + (setf + (cl-getf (sly-stickers--replay-data) :ignore-zombies-p) + (not (cl-getf (sly-stickers--replay-data) :ignore-zombies-p))))) + (if switch + (sly-message "Now ignoring zombie stickers") + (sly-message "No longer ignoring zombie stickers"))) + (sly-stickers-replay-refresh 0 nil t)) + +(defun sly-stickers-replay-pop-to-current-sticker (sticker-id) + "Pop to sticker with STICKER-ID" + (interactive (list + (sly-stickers-replay--current-sticker-interactive + "Pop to which sticker id?"))) + (sly-stickers--find-and-flash sticker-id + :otherwise #'sly-error)) + +(defun sly-stickers-replay-toggle-pop-to-stickers () + "Toggle popping to stickers when replaying sticker recordings." + (interactive) + (set (make-local-variable 'sly-stickers--replay-pop-to-stickers) + (not sly-stickers--replay-pop-to-stickers)) + (if sly-stickers--replay-pop-to-stickers + (sly-message "Auto-popping to stickers ON") + (sly-message "Auto-popping to stickers OFF"))) + +(defun sly-stickers-replay-reset-ignore-list () + "Reset the sticker ignore specs" + (interactive) + (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) nil) + (sly-stickers-replay-refresh 0 nil t)) + +(defun sly-stickers-fetch () + "Fetch recordings from Slynk and update stickers accordingly. +See also `sly-stickers-replay'." + (interactive) + (sly-eval-async `(slynk-stickers:fetch ',(sly-stickers--zombies)) + #'(lambda (result) + (sly-stickers--reset-zombies) + (let ((message + (format "Fetched recordings for %s armed stickers" + (length result)))) + (cl-loop for sticker-description in result + ;; Although we are analysing sticker descriptions + ;; here, recordings are made to pass to + ;; `sly-stickers--sticker-by-id', even if they are + ;; are `sly-stickers--recording-void-p', which is + ;; the case if the sticker has never been + ;; traversed. + ;; + for recording = + (sly-stickers--make-recording sticker-description) + for sticker = + (sly-stickers--sticker-by-id + (sly-stickers--recording-sticker-id recording)) + when sticker + do (sly-stickers--populate-sticker sticker recording)) + (sly-message message))) + "CL_USER")) + +(defun sly-stickers-forget (&optional howmany interactive) + "Forget about sticker recordings in the Slynk side. +If HOWMANY is non-nil it must be a number stating how many +recordings to forget about. In this cases Because 0 is an index, +in the `nth' sense, the HOWMANYth recording survives." + (interactive (list (and (numberp current-prefix-arg) + current-prefix-arg) + t)) + (when (or (not interactive) + (sly-y-or-n-p "Really forget about sticker recordings?")) + (sly-eval `(slynk-stickers:forget ',(sly-stickers--zombies) ,howmany)) + (sly-stickers--reset-zombies) + (setf (cl-getf (sly-stickers--replay-data) :rec) nil + (cl-getf (sly-stickers--replay-data) :old-total) nil) + (when interactive + (sly-message "Forgot all about sticker recordings.")) + (when (eq major-mode 'sly-stickers--replay-mode) + (sly-stickers-replay-refresh 0 t t)))) + + +;;;; Breaking stickers +(defun sly-stickers--handle-break (extra) + (sly-dcase extra + ((:slynk-after-sticker description) + (let ((sticker-id (cl-first description)) + (recording (sly-stickers--make-recording description))) + (sly-stickers--find-and-flash sticker-id + :otherwise 'sly-message) + (insert + "\n\n" + (sly-stickers--pretty-describe-recording recording + )))) + ((:slynk-before-sticker sticker-id) + (sly-stickers--find-and-flash sticker-id + :otherwise 'sly-message)) + (;; don't do anything if we don't know this "extra" info + t + nil))) + + +(defun sly-stickers-toggle-break-on-stickers () + (interactive) + (let ((break-p (sly-eval '(slynk-stickers:toggle-break-on-stickers)))) + (sly-message "Breaking on stickers is %s" (if break-p "ON" "OFF")))) + + +;;;; Functions for examining recordings +;;;; + + +(eval-after-load "sly-mrepl" + `(progn + (button-type-put 'sly-stickers-sticker + 'sly-mrepl-copy-part-to-repl + 'sly-stickers--copy-recording-to-repl) + (button-type-put 'sly-stickers--recording-part + 'sly-mrepl-copy-part-to-repl + 'sly-stickers--copy-recording-to-repl))) + + +;;; shoosh byte-compiler +(declare-function sly-mrepl--save-and-copy-for-repl nil) +(cl-defun sly-stickers--copy-recording-to-repl + (_sticker-id recording &optional (vindex 0)) + (check-recording recording) + (sly-mrepl--save-and-copy-for-repl + `(slynk-stickers:find-recording-or-lose + ,(sly-stickers--recording-id recording) + ,vindex) + :before (format "Returning values of recording %s of sticker %s" + (sly-stickers--recording-id recording) + (sly-stickers--recording-sticker-id recording)))) + +(defun check-recording (recording) + (cond ((null recording) + (sly-error "This sticker doesn't seem to have any recordings")) + ((not (eq (sly-stickers--recording-sly-connection recording) + (sly-current-connection))) + (sly-error "Recording is for a different connection (%s)" + (sly-connection-name + (sly-stickers--recording-sly-connection recording)))))) + +(cl-defun sly-stickers--inspect-recording + (_sticker-id recording &optional (vindex 0)) + (check-recording recording) + (sly-eval-for-inspector + `(slynk-stickers:inspect-sticker-recording + ,(sly-stickers--recording-id recording) + ,vindex))) + +;;;; Sticker-aware compilation +;;;; + +(cl-defun sly-stickers--compile-region-aware-of-stickers-1 + (start end callback &key sync fallback flash) + "Compile from START to END considering stickers. +After compilation call CALLBACK with the stickers and the +compilation result. If SYNC, use `sly-eval' other wise use +`sly-eval-async'. If FALLBACK, send the uninstrumneted region as +a fallback. If FLASH, flash the compiled region." + (let* ((uninstrumented (buffer-substring-no-properties start end)) + (stickers (sly-stickers--stickers-between start end)) + (original-buffer (current-buffer))) + (cond (stickers + (when flash + (sly-flash-region start end :face 'sly-stickers-armed-face)) + (sly-with-popup-buffer ((sly-buffer-name :stickers :hidden t) + :select :hidden) + (mapc #'delete-overlay (overlays-in (point-min) (point-max))) + (insert uninstrumented) + ;; Use a second set of overlays placed just in the + ;; pre-compilation buffer. We need this to correctly keep + ;; track of the markers because in this buffer we are going + ;; to change actual text + ;; + (cl-loop for sticker in stickers + for overlay = + (make-overlay (- (button-start sticker) (1- start)) + (- (button-end sticker) (1- start))) + do (overlay-put overlay 'sly-stickers--sticker sticker)) + (cl-loop for overlay in (overlays-in (point-min) (point-max)) + for sticker = (overlay-get overlay 'sly-stickers--sticker) + do + (sly-stickers--arm-sticker sticker) + (goto-char (overlay-start overlay)) + (insert (format "(slynk-stickers:record %d " + (sly-stickers--sticker-id sticker))) + (goto-char (overlay-end overlay)) + (insert ")")) + ;; Now send both the instrumented and uninstrumented + ;; string to the Lisp + ;; + (let ((instrumented (buffer-substring-no-properties (point-min) + (point-max))) + (new-ids (mapcar #'sly-stickers--sticker-id stickers))) + (with-current-buffer original-buffer + (let ((form `(slynk-stickers:compile-for-stickers + ',new-ids + ',(sly-stickers--zombies) + ,instrumented + ,(when fallback uninstrumented) + ,(buffer-name) + ',(sly-compilation-position start) + ,(if (buffer-file-name) + (sly-to-lisp-filename (buffer-file-name))) + ',sly-compilation-policy))) + (cond (sync + (funcall callback + stickers + (sly-eval form)) + (sly-stickers--reset-zombies)) + (t (sly-eval-async form + (lambda (result) + (sly-stickers--reset-zombies) + (funcall callback stickers result)))))))))) + (t + (sly-compile-region-as-string start end))))) + +(defun sly-stickers-compile-region-aware-of-stickers (start end) + "Compile region from START to END aware of stickers. +Intended to be placed in `sly-compile-region-function'" + (sly-stickers--compile-region-aware-of-stickers-1 + start end + (lambda (stickers result-and-stuck-p) + (cl-destructuring-bind (result &optional stuck-p) + result-and-stuck-p + (unless stuck-p + (mapc #'sly-stickers--disarm-sticker stickers)) + (sly-compilation-finished + result + nil + (if stuck-p + (format " (%d stickers armed)" (length stickers)) + " (stickers failed to stick)")))) + :fallback t + :flash t)) + +(defun sly-stickers-after-buffer-compilation (success _notes buffer loadp) + "After compilation, compile regions with stickers. +Intented to be placed in `sly-compilation-finished-hook'" + (when (and buffer loadp success) + (save-restriction + (widen) + (let* ((all-stickers (sly-stickers--stickers-between + (point-min) (point-max))) + (regions (cl-loop for sticker in all-stickers + for region = (sly-region-for-defun-at-point + (overlay-start sticker)) + unless (member region regions) + collect region into regions + finally (cl-return regions)))) + (when regions + (cl-loop + with successful + with unsuccessful + for region in regions + do + (sly-stickers--compile-region-aware-of-stickers-1 + (car region) (cadr region) + (lambda (stickers result) + (cond (result + (push (cons region stickers) successful)) + (t + (mapc #'sly-stickers--disarm-sticker stickers) + (push (cons region stickers) unsuccessful)))) + :sync t) + finally + (sly-temp-message + 3 3 + "%s stickers stuck in %s regions, %s disarmed in %s regions" + (cl-reduce #'+ successful :key (lambda (x) (length (cdr x)))) + (length successful) + (cl-reduce #'+ unsuccessful :key (lambda (x) (length (cdr x)))) + (length unsuccessful)))))))) + + +;;;; Menu +;;;; + +(easy-menu-define sly-stickers--shortcut-menu nil + "Placing stickers in `lisp-mode' buffers." + (let* ((in-source-file 'sly-stickers-mode) + (connected '(sly-connected-p))) + `("Stickers" + ["Add or remove sticker at point" + sly-stickers-dwim ,in-source-file] + ["Delete stickers from top-level form" + sly-stickers-clear-defun-stickers ,in-source-file] + ["Delete stickers from buffer" + sly-stickers-clear-buffer-stickers ,in-source-file] + "--" + ["Start sticker recording replay" + sly-stickers-replay ,connected] + ["Fetch most recent recordings" + sly-stickers-fetch ,connected] + ["Toggle breaking on stickers" + sly-stickers-toggle-break-on-stickers ,connected]))) + +(easy-menu-add-item sly-menu nil sly-stickers--shortcut-menu "Documentation") + +(provide 'sly-stickers) +;;; sly-stickers.el ends here + blob - /dev/null blob + ec36a895cd54e0e73e48926260b8151ee132f903 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-trace-dialog.el @@ -0,0 +1,744 @@ +;;; -*- coding: utf-8; lexical-binding: t -*- +;;; +;;; sly-trace-dialog.el -- a navigable dialog of inspectable trace entries +;;; +;;; TODO: implement better wrap interface for sbcl method, labels and such +;;; TODO: backtrace printing is very slow +;;; +(require 'sly) +(require 'sly-parse "lib/sly-parse") +(require 'cl-lib) + +(define-sly-contrib sly-trace-dialog + "Provide an interactive trace dialog buffer for managing and +inspecting details of traced functions. Invoke this dialog with C-c T." + (:authors "João Távora ") + (:license "GPL") + (:slynk-dependencies slynk/trace-dialog) + (:on-load (add-hook 'sly-mode-hook 'sly-trace-dialog-shortcut-mode) + (define-key sly-selector-map (kbd "T") 'sly-trace-dialog)) + (:on-unload (remove-hook 'sly-mode-hook 'sly-trace-dialogn-shortcut-mode))) + + +;;;; Variables +;;; +(defvar sly-trace-dialog-flash t + "Non-nil means flash the updated region of the SLY Trace Dialog. ") + +(defvar sly-trace-dialog--specs-overlay nil) + +(defvar sly-trace-dialog--progress-overlay nil) + +(defvar sly-trace-dialog--tree-overlay nil) + +(defvar sly-trace-dialog--collapse-chars (cons "-" "+")) + + +;;;; Local trace entry model +(defvar sly-trace-dialog--traces nil) + +(cl-defstruct (sly-trace-dialog--trace + (:constructor sly-trace-dialog--make-trace)) + id + parent + spec + args + retlist + depth + beg + end + collapse-button-marker + summary-beg + children-end + collapsed-p) + +(defun sly-trace-dialog--find-trace (id) + (gethash id sly-trace-dialog--traces)) + + +;;;; Modes and mode maps +;;; +(defvar sly-trace-dialog-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "G") 'sly-trace-dialog-fetch-traces) + (define-key map (kbd "C-k") 'sly-trace-dialog-clear-fetched-traces) + (define-key map (kbd "g") 'sly-trace-dialog-fetch-status) + + (define-key map (kbd "q") 'quit-window) + + (set-keymap-parent map button-buffer-map) + map)) + +(define-derived-mode sly-trace-dialog-mode fundamental-mode + "SLY Trace Dialog" "Mode for controlling SLY's Trace Dialog" + (set-syntax-table lisp-mode-syntax-table) + (read-only-mode 1) + (sly-mode 1) + (add-to-list (make-local-variable 'sly-trace-dialog-after-toggle-hook) + 'sly-trace-dialog-fetch-status)) + +(defvar sly-trace-dialog-shortcut-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c T") 'sly-trace-dialog) + (define-key map (kbd "C-c C-t") 'sly-trace-dialog-toggle-trace) + (define-key map (kbd "C-c M-t") + (if (featurep 'sly-fancy-trace) + 'sly-toggle-fancy-trace + 'sly-toggle-trace-fdefinition)) + map)) + +(define-minor-mode sly-trace-dialog-shortcut-mode + "Add keybindings for accessing SLY's Trace Dialog.") + +(easy-menu-define sly-trace-dialog--shortcut-menu nil + "Menu setting traces from anywhere in SLY." + (let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode)) + (_dialog-live `(and ,in-dialog + (memq sly-buffer-connection sly-net-processes))) + (connected '(sly-connected-p))) + `("Trace" + ["Toggle trace.." sly-trace-dialog-toggle-trace ,connected] + ["Untrace all" sly-trace-dialog-untrace-all ,connected] + ["Trace complex spec" sly-trace-dialog-toggle-complex-trace ,connected] + ["Open Trace dialog" sly-trace-dialog (and ,connected (not ,in-dialog))] + "--" + [ "Regular lisp trace..." sly-toggle-fancy-trace ,connected]))) + +(easy-menu-add-item sly-menu nil sly-trace-dialog--shortcut-menu "Documentation") + +(easy-menu-define sly-trace-dialog--menu sly-trace-dialog-mode-map + "Menu for SLY's Trace Dialog" + (let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode)) + (dialog-live `(and ,in-dialog + (memq sly-buffer-connection sly-net-processes)))) + `("SLY-Trace" + [ "Refresh traces and progress" sly-trace-dialog-fetch-status + ,dialog-live] + [ "Fetch next batch" sly-trace-dialog-fetch-traces ,dialog-live] + [ "Clear all fetched traces" sly-trace-dialog-clear-fetched-traces + ,dialog-live] + [ "Toggle details" sly-trace-dialog-hide-details-mode ,in-dialog] + [ "Toggle autofollow" sly-trace-dialog-autofollow-mode ,in-dialog]))) + +(define-minor-mode sly-trace-dialog-hide-details-mode + "Hide details in `sly-trace-dialog-mode'" + nil " Brief" + :group 'sly-trace-dialog + (unless (derived-mode-p 'sly-trace-dialog-mode) + (error "Not a SLY Trace Dialog buffer")) + (sly-trace-dialog--set-hide-details-mode)) + +(define-minor-mode sly-trace-dialog-autofollow-mode + "Automatically inspect trace entries from `sly-trace-dialog-mode'" + nil " Autofollow" + :group 'sly-trace-dialog + (unless (derived-mode-p 'sly-trace-dialog-mode) + (error "Not a SLY Trace Dialog buffer"))) + + +;;;; Helper functions +;;; +(defmacro sly-trace-dialog--insert-and-overlay (string overlay) + `(save-restriction + (let ((inhibit-read-only t)) + (narrow-to-region (point) (point)) + (insert ,string "\n") + (set (make-local-variable ',overlay) + (let ((overlay (make-overlay (point-min) + (point-max) + (current-buffer) + nil + t))) + (move-overlay overlay (overlay-start overlay) + (1- (overlay-end overlay))) + overlay))))) + +(defun sly-trace-dialog--buffer-name () + (sly-buffer-name :traces :connection (sly-current-connection))) + +(defun sly-trace-dialog--live-dialog (&optional buffer-or-name) + (let ((buffer-or-name (or buffer-or-name + (sly-trace-dialog--buffer-name)))) + (and (buffer-live-p (get-buffer buffer-or-name)) + (with-current-buffer buffer-or-name + (memq sly-buffer-connection sly-net-processes)) + buffer-or-name))) + +(defun sly-trace-dialog--ensure-buffer () + (let ((name (sly-trace-dialog--buffer-name))) + (or (sly-trace-dialog--live-dialog name) + (let ((connection (sly-current-connection))) + (with-current-buffer (get-buffer-create name) + (let ((inhibit-read-only t)) + (erase-buffer)) + (sly-trace-dialog-mode) + (save-excursion + (buffer-disable-undo) + (sly-trace-dialog--insert-and-overlay + "[waiting for the traced specs to be available]" + sly-trace-dialog--specs-overlay) + (sly-trace-dialog--insert-and-overlay + "[waiting for some info on trace download progress ]" + sly-trace-dialog--progress-overlay) + (sly-trace-dialog--insert-and-overlay + "[waiting for the actual traces to be available]" + sly-trace-dialog--tree-overlay) + (current-buffer)) + (setq sly-buffer-connection connection) + (current-buffer)))))) + +(defun sly-trace-dialog--set-collapsed (collapsed-p trace button) + (save-excursion + (setf (sly-trace-dialog--trace-collapsed-p trace) collapsed-p) + (sly-trace-dialog--go-replace-char-at + button + (if collapsed-p + (cdr sly-trace-dialog--collapse-chars) + (car sly-trace-dialog--collapse-chars))) + (sly-trace-dialog--hide-unhide + (sly-trace-dialog--trace-summary-beg trace) + (sly-trace-dialog--trace-end trace) + (if collapsed-p 1 -1)) + (sly-trace-dialog--hide-unhide + (sly-trace-dialog--trace-end trace) + (sly-trace-dialog--trace-children-end trace) + (if collapsed-p 1 -1)))) + +(defun sly-trace-dialog--hide-unhide (start-pos end-pos delta) + (cl-loop with inhibit-read-only = t + for pos = start-pos then next + for next = (next-single-property-change + pos + 'sly-trace-dialog--hidden-level + nil + end-pos) + for hidden-level = (+ (or (get-text-property + pos + 'sly-trace-dialog--hidden-level) + 0) + delta) + do (add-text-properties pos next + (list 'sly-trace-dialog--hidden-level + hidden-level + 'invisible + (cl-plusp hidden-level))) + while (< next end-pos))) + +(defun sly-trace-dialog--set-hide-details-mode () + (cl-loop for trace being the hash-values of sly-trace-dialog--traces + do (sly-trace-dialog--hide-unhide + (sly-trace-dialog--trace-summary-beg trace) + (sly-trace-dialog--trace-end trace) + (if sly-trace-dialog-hide-details-mode 1 -1)))) + +(defun sly-trace-dialog--format (fmt-string &rest args) + (let* ((string (apply #'format fmt-string args)) + (indent (make-string (max 2 + (- 50 (length string))) ? ))) + (format "%s%s" string indent))) + +(defun sly-trace-dialog--call-maintaining-properties (pos fn) + (save-excursion + (goto-char pos) + (let* ((saved-props (text-properties-at pos)) + (saved-point (point)) + (inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (funcall fn) + (add-text-properties saved-point (point) saved-props) + (if (markerp pos) (set-marker pos saved-point))))) + +(cl-defmacro sly-trace-dialog--maintaining-properties (pos + &body body) + (declare (indent 1)) + `(sly-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) + +(defun sly-trace-dialog--go-replace-char-at (pos char) + (sly-trace-dialog--maintaining-properties pos + (delete-char 1) + (insert char))) + + +;;;; Handlers for the *trace-dialog* buffer +;;; +(defun sly-trace-dialog--open-specs (traced-specs) + (let ((make-report-spec-fn-fn + (lambda (&optional form) + (lambda (_button) + (sly-eval-async + `(cl:progn + ,form + (slynk-trace-dialog:report-specs)) + #'(lambda (results) + (sly-trace-dialog--open-specs results))))))) + (sly-refreshing + (:overlay sly-trace-dialog--specs-overlay + :recover-point-p t) + (insert + (sly-trace-dialog--format "Traced specs (%s)" (length traced-specs)) + (sly-make-action-button "[refresh]" + (funcall make-report-spec-fn-fn)) + "\n" (make-string 50 ? ) + (sly-make-action-button + "[untrace all]" + (funcall make-report-spec-fn-fn `(slynk-trace-dialog:dialog-untrace-all))) + "\n\n") + (cl-loop for (spec-pretty . spec) in traced-specs + do (insert + " " + (sly-make-action-button + "[untrace]" + (funcall make-report-spec-fn-fn + `(slynk-trace-dialog:dialog-untrace ',spec))) + (format " %s" spec-pretty) + "\n"))))) + +(defvar sly-trace-dialog--fetch-key nil) + +(defvar sly-trace-dialog--stop-fetching nil) + +(defun sly-trace-dialog--update-progress (total &optional show-stop-p remaining-p) + ;; `remaining-p' indicates `total' is the number of remaining traces. + (sly-refreshing + (:overlay sly-trace-dialog--progress-overlay + :recover-point-p t) + (let* ((done (hash-table-count sly-trace-dialog--traces)) + (total (if remaining-p (+ done total) total))) + (insert + (sly-trace-dialog--format "Trace collection status (%d/%s)" + done + (or total "0")) + (sly-make-action-button "[refresh]" + #'(lambda (_button) + (sly-trace-dialog-fetch-progress)))) + + (when (and total (cl-plusp (- total done))) + (insert "\n" (make-string 50 ? ) + (sly-make-action-button + "[fetch next batch]" + #'(lambda (_button) + (sly-trace-dialog-fetch-traces nil))) + "\n" (make-string 50 ? ) + (sly-make-action-button + "[fetch all]" + #'(lambda (_button) + (sly-trace-dialog-fetch-traces t))))) + (when total + (insert "\n" (make-string 50 ? ) + (sly-make-action-button + "[clear]" + #'(lambda (_button) + (sly-trace-dialog-clear-fetched-traces))))) + (when show-stop-p + (insert "\n" (make-string 50 ? ) + (sly-make-action-button + "[stop]" + #'(lambda (_button) + (setq sly-trace-dialog--stop-fetching t))))) + (insert "\n\n")))) + + +;;;; Rendering traces +;;; + +(define-button-type 'sly-trace-dialog-part :supertype 'sly-part + 'sly-button-inspect + #'(lambda (trace-id part-id type) + (sly-eval-for-inspector + `(slynk-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) + :inspector-name (sly-maybe-read-inspector-name))) + 'sly-button-pretty-print + #'(lambda (trace-id part-id type) + (sly-eval-describe + `(slynk-trace-dialog:pprint-trace-part ,trace-id ,part-id ,type))) + 'sly-button-describe + #'(lambda (trace-id part-id type) + (sly-eval-describe + `(slynk-trace-dialog:describe-trace-part ,trace-id ,part-id ,type)))) + +(defun sly-trace-dialog-part-button (part-id part-text trace-id type) + (sly--make-text-button part-text nil + :type 'sly-trace-dialog-part + 'part-args (list trace-id part-id type) + 'part-label (format "%s %s" + (capitalize + (substring (symbol-name type) 1)) + part-id))) + +(define-button-type 'sly-trace-dialog-spec :supertype 'sly-part + 'action 'sly-button-show-source + 'sly-button-inspect + #'(lambda (trace-id _spec) + (sly-eval-for-inspector `(slynk-trace-dialog:inspect-trace ,trace-id) + :inspector-name "trace-entries")) + 'sly-button-show-source + #'(lambda (trace-id _spec) + (sly-eval-async + `(slynk-trace-dialog:trace-location ,trace-id) + #'(lambda (location) + (sly--display-source-location location 'noerror)))) + 'point-entered + #'(lambda (before after) + (let ((button (sly-button-at after nil 'no-error))) + (when (and (not (sly-button-at before nil 'no-error)) + button + sly-trace-dialog-autofollow-mode) + ;; we can't quite `push-button' here, because + ;; of the need for `save-selected-window' + ;; + (let ((id (button-get button 'trace-id))) + (sly-eval-for-inspector + `(slynk-trace-dialog:inspect-trace ,id) + :inspector-name "trace-entries" + :save-selected-window t)))))) + +(defun sly-trace-dialog-spec-button (label trace &rest props) + (let ((id (sly-trace-dialog--trace-id trace))) + (apply #'sly--make-text-button label nil + :type 'sly-trace-dialog-spec + 'trace-id id + 'part-args (list id + (cdr (sly-trace-dialog--trace-spec trace))) + 'part-label (format "Trace entry: %s" id) + props))) + +(defun sly-trace-dialog--draw-tree-lines (start offset direction) + (save-excursion + (let ((inhibit-point-motion-hooks t)) + (goto-char start) + (cl-loop with replace-set = (if (eq direction 'down) + '(? ) + '(? ?`)) + for line-beginning = (line-beginning-position + (if (eq direction 'down) + 2 0)) + for pos = (+ line-beginning offset) + while (and (< (point-min) line-beginning) + (< line-beginning (point-max)) + (memq (char-after pos) replace-set)) + do + (sly-trace-dialog--go-replace-char-at pos "|") + (goto-char pos))))) + +(defun sly-trace-dialog--make-indent (depth suffix) + (concat (make-string (* 3 (max 0 (1- depth))) ? ) + (if (cl-plusp depth) suffix))) + +(defun sly-trace-dialog--make-collapse-button (trace) + (sly-make-action-button (if (sly-trace-dialog--trace-collapsed-p trace) + (cdr sly-trace-dialog--collapse-chars) + (car sly-trace-dialog--collapse-chars)) + #'(lambda (button) + (sly-trace-dialog--set-collapsed + (not (sly-trace-dialog--trace-collapsed-p + trace)) + trace + button)))) + +(defun sly-trace-dialog--insert-trace (trace) + (let* ((id (sly-trace-dialog--trace-id trace)) + (parent (sly-trace-dialog--trace-parent trace)) + (has-children-p (sly-trace-dialog--trace-children-end trace)) + (indent-spec (sly-trace-dialog--make-indent + (sly-trace-dialog--trace-depth trace) + "`--")) + (indent-summary (sly-trace-dialog--make-indent + (sly-trace-dialog--trace-depth trace) + " ")) + (id-string + (sly-trace-dialog-spec-button + (format "%4s" id) trace 'skip t 'action 'sly-button-inspect)) + (spec-button (sly-trace-dialog-spec-button + (format "%s" (car (sly-trace-dialog--trace-spec trace))) + trace)) + (summary (cl-loop for (type objects marker) in + `((:arg ,(sly-trace-dialog--trace-args trace) + " > ") + (:retval ,(sly-trace-dialog--trace-retlist trace) + " < ")) + concat (cl-loop for object in objects + concat " " + concat indent-summary + concat marker + concat (sly-trace-dialog-part-button + (cl-first object) + (cl-second object) + id + type) + concat "\n")))) + (puthash id trace sly-trace-dialog--traces) + ;; insert and propertize the text + ;; + (setf (sly-trace-dialog--trace-beg trace) (point-marker)) + (insert id-string " ") + (insert indent-spec) + (if has-children-p + (insert (sly-trace-dialog--make-collapse-button trace)) + (setf (sly-trace-dialog--trace-collapse-button-marker trace) + (point-marker)) + (insert "-")) + (insert " " spec-button "\n") + (setf (sly-trace-dialog--trace-summary-beg trace) (point-marker)) + (insert summary) + (setf (sly-trace-dialog--trace-end trace) (point-marker)) + (set-marker-insertion-type (sly-trace-dialog--trace-beg trace) t) + + ;; respect brief mode and collapsed state + ;; + (cl-loop for condition in (list sly-trace-dialog-hide-details-mode + (sly-trace-dialog--trace-collapsed-p trace)) + when condition + do (sly-trace-dialog--hide-unhide + (sly-trace-dialog--trace-summary-beg + trace) + (sly-trace-dialog--trace-end trace) + 1)) + (cl-loop for tr = trace then parent + for parent = (sly-trace-dialog--trace-parent tr) + while parent + when (sly-trace-dialog--trace-collapsed-p parent) + do (sly-trace-dialog--hide-unhide + (sly-trace-dialog--trace-beg trace) + (sly-trace-dialog--trace-end trace) + (+ 1 + (or (get-text-property (sly-trace-dialog--trace-beg parent) + 'sly-trace-dialog--hidden-level) + 0))) + (cl-return)) + ;; maybe add the collapse-button to the parent in case it didn't + ;; have one already + ;; + (when (and parent + (sly-trace-dialog--trace-collapse-button-marker parent)) + (sly-trace-dialog--maintaining-properties + (sly-trace-dialog--trace-collapse-button-marker parent) + (delete-char 1) + (insert (sly-trace-dialog--make-collapse-button parent)) + (setf (sly-trace-dialog--trace-collapse-button-marker parent) + nil))) + ;; draw the tree lines + ;; + (when parent + (sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace) + (+ 2 (length indent-spec)) + 'up)) + (when has-children-p + (sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace) + (+ 5 (length indent-spec)) + 'down)) + ;; set the "children-end" slot + ;; + (unless (sly-trace-dialog--trace-children-end trace) + (cl-loop for parent = trace + then (sly-trace-dialog--trace-parent parent) + while parent + do + (setf (sly-trace-dialog--trace-children-end parent) + (sly-trace-dialog--trace-end trace)))))) + +(defun sly-trace-dialog--render-trace (trace) + ;; Render the trace entry in the appropriate place. + ;; + ;; A trace becomes a few lines of slightly propertized text in the + ;; buffer, inserted by `sly-trace-dialog--insert-trace', bound by + ;; point markers that we use here. + ;; + ;; The new trace might be replacing an existing one, or otherwise + ;; must be placed under its existing parent which might or might not + ;; be the last entry inserted. + ;; + (let ((existing (sly-trace-dialog--find-trace + (sly-trace-dialog--trace-id trace))) + (parent (sly-trace-dialog--trace-parent trace))) + (cond (existing + ;; Other traces might already reference `existing' and with + ;; need to maintain that eqness. Best way to do that is + ;; destructively modify `existing' with the new retlist... + ;; + (setf (sly-trace-dialog--trace-retlist existing) + (sly-trace-dialog--trace-retlist trace)) + ;; Now, before deleting and re-inserting `existing' at an + ;; arbitrary point in the tree, note that it's + ;; "children-end" marker is already non-nil, and informs us + ;; about its parenthood status. We want to 1. leave it + ;; alone if it's already a parent, or 2. set it to nil if + ;; it's a leaf, thus forcing the needed update of the + ;; parents' "children-end" marker. + ;; + (when (= (sly-trace-dialog--trace-children-end existing) + (sly-trace-dialog--trace-end existing)) + (setf (sly-trace-dialog--trace-children-end existing) nil)) + (delete-region (sly-trace-dialog--trace-beg existing) + (sly-trace-dialog--trace-end existing)) + (goto-char (sly-trace-dialog--trace-end existing)) + ;; Remember to set `trace' to be `existing' + ;; + (setq trace existing)) + (parent + (goto-char (1+ (sly-trace-dialog--trace-children-end parent)))) + (;; top level trace + t + (goto-char (point-max)))) + (goto-char (line-beginning-position)) + (sly-trace-dialog--insert-trace trace))) + +(defun sly-trace-dialog--update-tree (tuples) + (save-excursion + (sly-refreshing + (:overlay sly-trace-dialog--tree-overlay + :dont-erase t) + (cl-loop for tuple in tuples + for parent = (sly-trace-dialog--find-trace (cl-second tuple)) + for trace = (sly-trace-dialog--make-trace + :id (cl-first tuple) + :parent parent + :spec (cl-third tuple) + :args (cl-fourth tuple) + :retlist (cl-fifth tuple) + :depth (if parent + (1+ (sly-trace-dialog--trace-depth + parent)) + 0)) + do (sly-trace-dialog--render-trace trace))))) + +(defun sly-trace-dialog--clear-local-tree () + (set (make-local-variable 'sly-trace-dialog--fetch-key) + (cl-gensym "sly-trace-dialog-fetch-key-")) + (set (make-local-variable 'sly-trace-dialog--traces) + (make-hash-table)) + (sly-refreshing + (:overlay sly-trace-dialog--tree-overlay)) + (sly-trace-dialog--update-progress nil)) + +(defun sly-trace-dialog--on-new-results (results &optional recurse) + (cl-destructuring-bind (tuples remaining reply-key) + results + (cond ((and sly-trace-dialog--fetch-key + (string= (symbol-name sly-trace-dialog--fetch-key) + (symbol-name reply-key))) + (sly-trace-dialog--update-tree tuples) + (sly-trace-dialog--update-progress + remaining + (and recurse + (cl-plusp remaining)) + t) + (when (and recurse + (not (prog1 sly-trace-dialog--stop-fetching + (setq sly-trace-dialog--stop-fetching nil))) + (cl-plusp remaining)) + (sly-eval-async `(slynk-trace-dialog:report-partial-tree + ',reply-key) + #'(lambda (results) (sly-trace-dialog--on-new-results + results + recurse)))))))) + + +;;;; Interactive functions +;;; +(defun sly-trace-dialog-fetch-specs () + "Refresh just list of traced specs." + (interactive) + (sly-eval-async `(slynk-trace-dialog:report-specs) + #'sly-trace-dialog--open-specs)) + +(defun sly-trace-dialog-fetch-progress () + (interactive) + (sly-eval-async + '(slynk-trace-dialog:report-total) + #'(lambda (total) + (sly-trace-dialog--update-progress + total)))) + +(defun sly-trace-dialog-fetch-status () + "Refresh just the status part of the SLY Trace Dialog" + (interactive) + (sly-trace-dialog-fetch-specs) + (sly-trace-dialog-fetch-progress)) + +(defun sly-trace-dialog-clear-fetched-traces (&optional interactive) + "Clear local and remote traces collected so far" + (interactive "p") + (when (or (not interactive) + (y-or-n-p "Clear all collected and fetched traces?")) + (sly-eval-async + '(slynk-trace-dialog:clear-trace-tree) + #'(lambda (_ignored) + (sly-trace-dialog--clear-local-tree))))) + +(defun sly-trace-dialog-fetch-traces (&optional recurse) + (interactive "P") + (setq sly-trace-dialog--stop-fetching nil) + (sly-eval-async `(slynk-trace-dialog:report-partial-tree + ',sly-trace-dialog--fetch-key) + #'(lambda (results) (sly-trace-dialog--on-new-results results + recurse)))) + +(defvar sly-trace-dialog-after-toggle-hook nil + "Hooks run after toggling a dialog-trace") + +(defun sly-trace-dialog-toggle-trace (&optional using-context-p) + "Toggle the dialog-trace of the spec at point. + +When USING-CONTEXT-P, attempt to decipher lambdas. methods and +other complicated function specs." + (interactive "P") + ;; Notice the use of "spec strings" here as opposed to the + ;; proper cons specs we use on the slynk side. + ;; + ;; Notice the conditional use of `sly-trace-query' found in + ;; slynk-fancy-trace.el + ;; + (let* ((spec-string (if using-context-p + (sly-extract-context) + (sly-symbol-at-point))) + (spec-string (if (fboundp 'sly-trace-query) + (sly-trace-query spec-string) + spec-string))) + (sly-message "%s" (sly-eval `(slynk-trace-dialog:dialog-toggle-trace + (slynk::from-string ,spec-string)))) + (run-hooks 'sly-trace-dialog-after-toggle-hook))) + +(defun sly-trace-dialog-untrace-all () + "Untrace all specs traced for the Trace Dialog." + (interactive) + (sly-eval-async `(slynk-trace-dialog:dialog-untrace-all) + #'(lambda (results) + (sly-message "%s dialog specs and %s regular specs untraced" + (cdr results) (car results) ))) + (run-hooks 'sly-trace-dialog-after-toggle-hook)) + +(defun sly-trace-dialog--update-existing-dialog () + (let ((existing (sly-trace-dialog--live-dialog))) + (when existing + (with-current-buffer existing + (sly-trace-dialog-fetch-status))))) + +(add-hook 'sly-trace-dialog-after-toggle-hook + 'sly-trace-dialog--update-existing-dialog) + +(defun sly-trace-dialog-toggle-complex-trace () + "Toggle the dialog-trace of the complex spec at point. + +See `sly-trace-dialog-toggle-trace'." + (interactive) + (sly-trace-dialog-toggle-trace t)) + +(defun sly-trace-dialog (&optional clear-and-fetch) + "Show trace dialog and refresh trace collection status. + +With optional CLEAR-AND-FETCH prefix arg, clear the current tree +and fetch a first batch of traces." + (interactive "P") + (with-current-buffer + ;; FIXME: refactor with `sly-with-popup-buffer' + (pop-to-buffer + (sly-trace-dialog--ensure-buffer) + `(display-buffer-reuse-window . ((inhibit-same-window . t)))) + (sly-trace-dialog-fetch-status) + (when (or clear-and-fetch + (null sly-trace-dialog--fetch-key)) + (sly-trace-dialog--clear-local-tree)) + (when clear-and-fetch + (sly-trace-dialog-fetch-traces nil)))) + +(provide 'sly-trace-dialog) blob - /dev/null blob + 8767cd5506062db2268dba0271d9ecfb93e545a7 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sly-tramp.el @@ -0,0 +1,123 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'tramp) +(require 'cl-lib) + +(define-sly-contrib sly-tramp + "Filename translations for tramp" + (:authors "Marco Baringer ") + (:license "GPL") + (:on-load + (setq sly-to-lisp-filename-function #'sly-tramp-to-lisp-filename) + (setq sly-from-lisp-filename-function #'sly-tramp-from-lisp-filename))) + +(defcustom sly-filename-translations nil + "Assoc list of hostnames and filename translation functions. +Each element is of the form (HOSTNAME-REGEXP TO-LISP FROM-LISP). + +HOSTNAME-REGEXP is a regexp which is applied to the connection's +sly-machine-instance. If HOSTNAME-REGEXP maches then the +corresponding TO-LISP and FROM-LISP functions will be used to +translate emacs filenames and lisp filenames. + +TO-LISP will be passed the filename of an emacs buffer and must +return a string which the underlying lisp understandas as a +pathname. FROM-LISP will be passed a pathname as returned by the +underlying lisp and must return something that emacs will +understand as a filename (this string will be passed to +find-file). + +This list will be traversed in order, so multiple matching +regexps are possible. + +Example: + +Assuming you run emacs locally and connect to sly running on +the machine 'soren' and you can connect with the username +'animaliter': + + (push (list \"^soren$\" + (lambda (emacs-filename) + (subseq emacs-filename (length \"/ssh:animaliter@soren:\"))) + (lambda (lisp-filename) + (concat \"/ssh:animaliter@soren:\" lisp-filename))) + sly-filename-translations) + +See also `sly-create-filename-translator'." + :type '(repeat (list :tag "Host description" + (regexp :tag "Hostname regexp") + (function :tag "To lisp function") + (function :tag "From lisp function"))) + :group 'sly-lisp) + +(defun sly-find-filename-translators (hostname) + (cond ((cdr (cl-assoc-if (lambda (regexp) (string-match regexp hostname)) + sly-filename-translations))) + (t (list #'identity #'identity)))) + +(defun sly-make-tramp-file-name (username remote-host lisp-filename) + "Tramp compatability function. + +Handles the signature of `tramp-make-tramp-file-name' changing +over time." + (cond + ((>= emacs-major-version 26) + ;; Emacs 26 requires the method to be provided and the signature of + ;; `tramp-make-tramp-file-name' has changed. + (tramp-make-tramp-file-name (tramp-find-method nil username remote-host) + username + nil + remote-host + nil + lisp-filename)) + ((boundp 'tramp-multi-methods) + (tramp-make-tramp-file-name nil nil + username + remote-host + lisp-filename)) + (t + (tramp-make-tramp-file-name nil + username + remote-host + lisp-filename)))) + +(cl-defun sly-create-filename-translator (&key machine-instance + remote-host + username) + "Creates a three element list suitable for push'ing onto +sly-filename-translations which uses Tramp to load files on +hostname using username. MACHINE-INSTANCE is a required +parameter, REMOTE-HOST defaults to MACHINE-INSTANCE and USERNAME +defaults to (user-login-name). + +MACHINE-INSTANCE is the value returned by sly-machine-instance, +which is just the value returned by cl:machine-instance on the +remote lisp. REMOTE-HOST is the fully qualified domain name (or +just the IP) of the remote machine. USERNAME is the username we +should login with. +The functions created here expect your tramp-default-method or + tramp-default-method-alist to be setup correctly." + (let ((remote-host (or remote-host machine-instance)) + (username (or username (user-login-name)))) + (list (concat "^" machine-instance "$") + (lambda (emacs-filename) + (tramp-file-name-localname + (tramp-dissect-file-name emacs-filename))) + `(lambda (lisp-filename) + (sly-make-tramp-file-name + ,username + ,remote-host + lisp-filename))))) + +(defun sly-tramp-to-lisp-filename (filename) + (funcall (if (let ((conn (sly-current-connection))) + (and conn (process-live-p conn))) + (cl-first (sly-find-filename-translators (sly-machine-instance))) + 'identity) + (expand-file-name filename))) + +(defun sly-tramp-from-lisp-filename (filename) + (funcall (cl-second (sly-find-filename-translators (sly-machine-instance))) + filename)) + +(provide 'sly-tramp) blob - /dev/null blob + bb78d688d2aef10c32dc955e3e9fee2d23443db0 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-arglists.lisp @@ -0,0 +1,1606 @@ +;;; slynk-arglists.lisp --- arglist related code ?? +;; +;; Authors: Matthias Koeppe +;; Tobias C. Rittweiler +;; and others +;; +;; License: Public Domain +;; + +(in-package :slynk) + +;;;; Utilities + +(defun compose (&rest functions) + "Compose FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (reduce #'funcall functions :initial-value x :from-end t))) + +(defun length= (seq n) + "Test for whether SEQ contains N number of elements. I.e. it's equivalent + to (= (LENGTH SEQ) N), but besides being more concise, it may also be more + efficiently implemented." + (etypecase seq + (list (do ((i n (1- i)) + (list seq (cdr list))) + ((or (<= i 0) (null list)) + (and (zerop i) (null list))))) + (sequence (= (length seq) n)))) + +(declaim (inline memq)) +(defun memq (item list) + (member item list :test #'eq)) + +(defun exactly-one-p (&rest values) + "If exactly one value in VALUES is non-NIL, this value is returned. +Otherwise NIL is returned." + (let ((found nil)) + (dolist (v values) + (when v (if found + (return-from exactly-one-p nil) + (setq found v)))) + found)) + +(defun valid-operator-symbol-p (symbol) + "Is SYMBOL the name of a function, a macro, or a special-operator?" + (or (fboundp symbol) + (macro-function symbol) + (special-operator-p symbol) + (member symbol '(declare declaim)))) + +(defun function-exists-p (form) + (and (valid-function-name-p form) + (fboundp form) + t)) + +(defmacro multiple-value-or (&rest forms) + (if (null forms) + nil + (let ((first (first forms)) + (rest (rest forms))) + `(let* ((values (multiple-value-list ,first)) + (primary-value (first values))) + (if primary-value + (values-list values) + (multiple-value-or ,@rest)))))) + +(defun arglist-available-p (arglist) + (not (eql arglist :not-available))) + +(defmacro with-available-arglist ((var &rest more-vars) form &body body) + `(multiple-value-bind (,var ,@more-vars) ,form + (if (eql ,var :not-available) + :not-available + (progn ,@body)))) + + +;;;; Arglist Definition + +(defstruct (arglist (:conc-name arglist.) (:predicate arglist-p)) + provided-args ; list of the provided actual arguments + required-args ; list of the required arguments + optional-args ; list of the optional arguments + key-p ; whether &key appeared + keyword-args ; list of the keywords + rest ; name of the &rest or &body argument (if any) + body-p ; whether the rest argument is a &body + allow-other-keys-p ; whether &allow-other-keys appeared + aux-args ; list of &aux variables + any-p ; whether &any appeared + any-args ; list of &any arguments [*] + known-junk ; &whole, &environment + unknown-junk) ; unparsed stuff + +;;; +;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp, +;;; and is only used to describe certain arglists that cannot be +;;; described in another way. +;;; +;;; &ANY is very similiar to &KEY but while &KEY is based upon +;;; the idea of a plist (key1 value1 key2 value2), &ANY is a +;;; cross between &OPTIONAL, &KEY and *FEATURES* lists: +;;; +;;; a) (&ANY :A :B :C) means that you can provide any (non-null) +;;; set consisting of the keywords `:A', `:B', or `:C' in +;;; the arglist. E.g. (:A) or (:C :B :A). +;;; +;;; (This is not restricted to keywords only, but any self-evaluating +;;; expression is allowed.) +;;; +;;; b) (&ANY (key1 v1) (key2 v2) (key3 v3)) means that you can +;;; provide any (non-null) set consisting of lists where +;;; the CAR of the list is one of `key1', `key2', or `key3'. +;;; E.g. ((key1 100) (key3 42)), or ((key3 66) (key2 23)) +;;; +;;; +;;; For example, a) let us describe the situations of EVAL-WHEN as +;;; +;;; (EVAL-WHEN (&ANY :compile-toplevel :load-toplevel :execute) &BODY body) +;;; +;;; and b) let us describe the optimization qualifiers that are valid +;;; in the declaration specifier `OPTIMIZE': +;;; +;;; (DECLARE (OPTIMIZE &ANY (compilation-speed 1) (safety 1) ...)) +;;; + +;; This is a wrapper object around anything that came from Slime and +;; could not reliably be read. +(defstruct (arglist-dummy + (:conc-name #:arglist-dummy.) + (:constructor make-arglist-dummy (string-representation))) + string-representation) + +(defun empty-arg-p (dummy) + (and (arglist-dummy-p dummy) + (zerop (length (arglist-dummy.string-representation dummy))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter +lambda-list-keywords+ + '(&provided &required &optional &rest &key &any))) + +(defmacro do-decoded-arglist (decoded-arglist &body clauses) + (assert (loop for clause in clauses + thereis (member (car clause) +lambda-list-keywords+))) + (flet ((parse-clauses (clauses) + (let* ((size (length +lambda-list-keywords+)) + (initial (make-hash-table :test #'eq :size size)) + (main (make-hash-table :test #'eq :size size)) + (final (make-hash-table :test #'eq :size size))) + (loop for clause in clauses + for lambda-list-keyword = (first clause) + for clause-parameter = (second clause) + do + (case clause-parameter + (:initially + (setf (gethash lambda-list-keyword initial) clause)) + (:finally + (setf (gethash lambda-list-keyword final) clause)) + (t + (setf (gethash lambda-list-keyword main) clause))) + finally + (return (values initial main final))))) + (generate-main-clause (clause arglist) + (destructure-case clause + ((&provided (&optional arg) . body) + (let ((gensym (gensym "PROVIDED-ARG+"))) + `(dolist (,gensym (arglist.provided-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&required (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.required-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body)))) + ((&optional (&optional arg init) . body) + (let ((optarg (gensym "OPTIONAL-ARG+"))) + `(dolist (,optarg (arglist.optional-args ,arglist)) + (declare (ignorable ,optarg)) + (let (,@(when arg + `((,arg (optional-arg.arg-name ,optarg)))) + ,@(when init + `((,init (optional-arg.default-arg ,optarg))))) + ,@body)))) + ((&key (&optional keyword arg init) . body) + (let ((keyarg (gensym "KEY-ARG+"))) + `(dolist (,keyarg (arglist.keyword-args ,arglist)) + (declare (ignorable ,keyarg)) + (let (,@(when keyword + `((,keyword (keyword-arg.keyword ,keyarg)))) + ,@(when arg + `((,arg (keyword-arg.arg-name ,keyarg)))) + ,@(when init + `((,init (keyword-arg.default-arg ,keyarg))))) + ,@body)))) + ((&rest (&optional arg body-p) . body) + `(when (arglist.rest ,arglist) + (let (,@(when arg `((,arg (arglist.rest ,arglist)))) + ,@(when body-p `((,body-p (arglist.body-p ,arglist))))) + ,@body))) + ((&any (&optional arg) . body) + (let ((gensym (gensym "REQUIRED-ARG+"))) + `(dolist (,gensym (arglist.any-args ,arglist)) + (declare (ignorable ,gensym)) + (let (,@(when arg `((,arg ,gensym)))) + ,@body))))))) + (let ((arglist (gensym "DECODED-ARGLIST+"))) + (multiple-value-bind (initially-clauses main-clauses finally-clauses) + (parse-clauses clauses) + `(let ((,arglist ,decoded-arglist)) + (block do-decoded-arglist + ,@(loop for keyword in '(&provided &required + &optional &rest &key &any) + append (cddr (gethash keyword initially-clauses)) + collect (let ((clause (gethash keyword main-clauses))) + (when clause + (generate-main-clause clause arglist))) + append (cddr (gethash keyword finally-clauses))))))))) + +;;;; Arglist Printing + +(defun undummy (x) + (if (typep x 'arglist-dummy) + (arglist-dummy.string-representation x) + (prin1-to-string x))) + +(defun print-decoded-arglist (arglist &key operator provided-args highlight) + (let ((first-space-after-operator (and operator t))) + (macrolet ((space () + ;; Kludge: When OPERATOR is not given, we don't want to + ;; print a space for the first argument. + `(if (not operator) + (setq operator t) + (progn (write-char #\space) + (if first-space-after-operator + (setq first-space-after-operator nil) + (pprint-newline :fill))))) + (with-highlighting ((&key index) &body body) + `(if (eql ,index (car highlight)) + (progn (princ "===> ") ,@body (princ " <===")) + (progn ,@body))) + (print-arglist-recursively (argl &key index) + `(if (eql ,index (car highlight)) + (print-decoded-arglist ,argl :highlight (cdr highlight)) + (print-decoded-arglist ,argl)))) + (let ((index 0)) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (when operator + (print-arg operator) + (pprint-indent :current 1)) ; 1 due to possibly added space + (do-decoded-arglist (remove-given-args arglist provided-args) + (&provided (arg) + (space) + (print-arg arg :literal-strings t) + (incf index)) + (&required (arg) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (print-arg arg))) + (incf index)) + (&optional :initially + (when (arglist.optional-args arglist) + (space) + (princ '&optional))) + (&optional (arg init-value) + (space) + (if (arglist-p arg) + (print-arglist-recursively arg :index index) + (with-highlighting (:index index) + (if (null init-value) + (print-arg arg) + (format t "~:@<~A ~A~@:>" + (undummy arg) (undummy init-value))))) + (incf index)) + (&key :initially + (when (arglist.key-p arglist) + (space) + (princ '&key))) + (&key (keyword arg init) + (space) + (if (arglist-p arg) + (pprint-logical-block (nil nil :prefix "(" :suffix ")") + (prin1 keyword) (space) + (print-arglist-recursively arg :index keyword)) + (with-highlighting (:index keyword) + (cond ((and init (keywordp keyword)) + (format t "~:@<~A ~A~@:>" keyword (undummy init))) + (init + (format t "~:@<(~A ..) ~A~@:>" + (undummy keyword) (undummy init))) + ((not (keywordp keyword)) + (format t "~:@<(~S ..)~@:>" keyword)) + (t + (princ keyword)))))) + (&key :finally + (when (arglist.allow-other-keys-p arglist) + (space) + (princ '&allow-other-keys))) + (&any :initially + (when (arglist.any-p arglist) + (space) + (princ '&any))) + (&any (arg) + (space) + (print-arg arg)) + (&rest (args bodyp) + (space) + (princ (if bodyp '&body '&rest)) + (space) + (if (arglist-p args) + (print-arglist-recursively args :index index) + (with-highlighting (:index index) + (print-arg args)))) + ;; FIXME: add &UNKNOWN-JUNK? + )))))) + +(defun print-arg (arg &key literal-strings) + (let ((arg (if (arglist-dummy-p arg) + (arglist-dummy.string-representation arg) + arg))) + (if (or + (and literal-strings + (stringp arg)) + (keywordp arg)) + (prin1 arg) + (princ arg)))) + +(defun print-decoded-arglist-as-template (decoded-arglist &key + (prefix "(") (suffix ")")) + (let ((first-p t)) + (flet ((space () + (unless first-p + (write-char #\space)) + (setq first-p nil)) + (print-arg-or-pattern (arg) + (etypecase arg + (symbol (if (keywordp arg) (prin1 arg) (princ arg))) + (string (princ arg)) + (list (princ arg)) + (arglist-dummy (princ + (arglist-dummy.string-representation arg))) + (arglist (print-decoded-arglist-as-template arg))) + (pprint-newline :fill))) + (pprint-logical-block (nil nil :prefix prefix :suffix suffix) + (do-decoded-arglist decoded-arglist + (&provided ()) ; do nothing; provided args are in the buffer already. + (&required (arg) + (space) (print-arg-or-pattern arg)) + (&optional (arg) + (space) (princ "[") (print-arg-or-pattern arg) (princ "]")) + (&key (keyword arg) + (space) + (prin1 (if (keywordp keyword) keyword `',keyword)) + (space) + (print-arg-or-pattern arg) + (pprint-newline :linear)) + (&any (arg) + (space) (print-arg-or-pattern arg)) + (&rest (args) + (when (or (not (arglist.keyword-args decoded-arglist)) + (arglist.allow-other-keys-p decoded-arglist)) + (space) + (format t "~A..." args)))))))) + +(defvar *arglist-pprint-bindings* + '((*print-case* . :downcase) + (*print-pretty* . t) + (*print-circle* . nil) + (*print-readably* . nil) + (*print-level* . 10) + (*print-length* . 20) + (*print-escape* . nil))) + +(defvar *arglist-show-packages* t) + +(defmacro with-arglist-io-syntax (&body body) + (let ((package (gensym))) + `(let ((,package *package*)) + (with-standard-io-syntax + (let ((*package* (if *arglist-show-packages* + *package* + ,package))) + (with-bindings *arglist-pprint-bindings* + ,@body)))))) + +(defun decoded-arglist-to-string (decoded-arglist + &key operator highlight + print-right-margin) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (let ((*print-right-margin* print-right-margin)) + (print-decoded-arglist decoded-arglist + :operator operator + :highlight highlight))))) + +(defun decoded-arglist-to-template-string (decoded-arglist + &key (prefix "(") (suffix ")")) + (with-output-to-string (*standard-output*) + (with-arglist-io-syntax + (print-decoded-arglist-as-template decoded-arglist + :prefix prefix + :suffix suffix)))) + +;;;; Arglist Decoding / Encoding + +(defun decode-required-arg (arg) + "ARG can be a symbol or a destructuring pattern." + (etypecase arg + (symbol arg) + (arglist-dummy arg) + (list (decode-arglist arg)) + (number arg))) + +(defun encode-required-arg (arg) + (etypecase arg + (symbol arg) + (arglist (encode-arglist arg)))) + +(defstruct (keyword-arg + (:conc-name keyword-arg.) + (:constructor %make-keyword-arg)) + keyword + arg-name + default-arg) + +(defun canonicalize-default-arg (form) + (if (equalp ''nil form) + nil + form)) + +(defun make-keyword-arg (keyword arg-name default-arg) + (%make-keyword-arg :keyword keyword + :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-keyword-arg (arg) + "Decode a keyword item of formal argument list. +Return three values: keyword, argument name, default arg." + (flet ((intern-as-keyword (arg) + (intern (etypecase arg + (symbol (symbol-name arg)) + (arglist-dummy (arglist-dummy.string-representation arg))) + +keyword-package+))) + (cond ((or (symbolp arg) (arglist-dummy-p arg)) + (make-keyword-arg (intern-as-keyword arg) arg nil)) + ((and (consp arg) + (consp (car arg))) + (make-keyword-arg (caar arg) + (decode-required-arg (cadar arg)) + (cadr arg))) + ((consp arg) + (make-keyword-arg (intern-as-keyword (car arg)) + (car arg) (cadr arg))) + (t + (error "Bad keyword item of formal argument list"))))) + +(defun encode-keyword-arg (arg) + (cond + ((arglist-p (keyword-arg.arg-name arg)) + ;; Destructuring pattern + (let ((keyword/name (list (keyword-arg.keyword arg) + (encode-required-arg + (keyword-arg.arg-name arg))))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))) + ((eql (intern (symbol-name (keyword-arg.arg-name arg)) + +keyword-package+) + (keyword-arg.keyword arg)) + (if (keyword-arg.default-arg arg) + (list (keyword-arg.arg-name arg) + (keyword-arg.default-arg arg)) + (keyword-arg.arg-name arg))) + (t + (let ((keyword/name (list (keyword-arg.keyword arg) + (keyword-arg.arg-name arg)))) + (if (keyword-arg.default-arg arg) + (list keyword/name + (keyword-arg.default-arg arg)) + (list keyword/name)))))) + +(progn + (assert (equalp (decode-keyword-arg 'x) + (make-keyword-arg :x 'x nil))) + (assert (equalp (decode-keyword-arg '(x t)) + (make-keyword-arg :x 'x t))) + (assert (equalp (decode-keyword-arg '((:x y))) + (make-keyword-arg :x 'y nil))) + (assert (equalp (decode-keyword-arg '((:x y) t)) + (make-keyword-arg :x 'y t)))) + +;;; FIXME suppliedp? +(defstruct (optional-arg + (:conc-name optional-arg.) + (:constructor %make-optional-arg)) + arg-name + default-arg) + +(defun make-optional-arg (arg-name default-arg) + (%make-optional-arg :arg-name arg-name + :default-arg (canonicalize-default-arg default-arg))) + +(defun decode-optional-arg (arg) + "Decode an optional item of a formal argument list. +Return an OPTIONAL-ARG structure." + (etypecase arg + (symbol (make-optional-arg arg nil)) + (arglist-dummy (make-optional-arg arg nil)) + (list (make-optional-arg (decode-required-arg (car arg)) + (cadr arg))))) + +(defun encode-optional-arg (optional-arg) + (if (or (optional-arg.default-arg optional-arg) + (arglist-p (optional-arg.arg-name optional-arg))) + (list (encode-required-arg + (optional-arg.arg-name optional-arg)) + (optional-arg.default-arg optional-arg)) + (optional-arg.arg-name optional-arg))) + +(progn + (assert (equalp (decode-optional-arg 'x) + (make-optional-arg 'x nil))) + (assert (equalp (decode-optional-arg '(x t)) + (make-optional-arg 'x t)))) + +(define-modify-macro nreversef () nreverse "Reverse the list in PLACE.") + +(defun decode-arglist (arglist) + "Parse the list ARGLIST and return an ARGLIST structure." + (if (eq arglist :not-available) (return-from decode-arglist arglist)) + (loop + with mode = nil + with result = (make-arglist) + for arg = (if (consp arglist) + (pop arglist) + (progn + (prog1 arglist + (setf mode '&rest + arglist nil)))) + do (cond + ((eql mode '&unknown-junk) + ;; don't leave this mode -- we don't know how the arglist + ;; after unknown lambda-list keywords is interpreted + (push arg (arglist.unknown-junk result))) + ((eql arg '&allow-other-keys) + (setf (arglist.allow-other-keys-p result) t)) + ((eql arg '&key) + (setf (arglist.key-p result) t + mode arg)) + ((memq arg '(&optional &rest &body &aux)) + (setq mode arg)) + ((memq arg '(&whole &environment)) + (setq mode arg) + (push arg (arglist.known-junk result))) + ((and (symbolp arg) + (string= (symbol-name arg) (string '#:&any))) ; may be interned + (setf (arglist.any-p result) t) ; in any *package*. + (setq mode '&any)) + ((memq arg lambda-list-keywords) + (setq mode '&unknown-junk) + (push arg (arglist.unknown-junk result))) + (t + (ecase mode + (&key + (push (decode-keyword-arg arg) + (arglist.keyword-args result))) + (&optional + (push (decode-optional-arg arg) + (arglist.optional-args result))) + (&body + (setf (arglist.body-p result) t + (arglist.rest result) arg)) + (&rest + (setf (arglist.rest result) arg)) + (&aux + (push (decode-optional-arg arg) + (arglist.aux-args result))) + ((nil) + (push (decode-required-arg arg) + (arglist.required-args result))) + ((&whole &environment) + (setf mode nil) + (push arg (arglist.known-junk result))) + (&any + (push arg (arglist.any-args result)))))) + until (null arglist) + finally (nreversef (arglist.required-args result)) + finally (nreversef (arglist.optional-args result)) + finally (nreversef (arglist.keyword-args result)) + finally (nreversef (arglist.aux-args result)) + finally (nreversef (arglist.any-args result)) + finally (nreversef (arglist.known-junk result)) + finally (nreversef (arglist.unknown-junk result)) + finally (assert (or (and (not (arglist.key-p result)) + (not (arglist.any-p result))) + (exactly-one-p (arglist.key-p result) + (arglist.any-p result)))) + finally (return result))) + +(defun encode-arglist (decoded-arglist) + (append (mapcar #'encode-required-arg + (arglist.required-args decoded-arglist)) + (when (arglist.optional-args decoded-arglist) + '(&optional)) + (mapcar #'encode-optional-arg + (arglist.optional-args decoded-arglist)) + (when (arglist.key-p decoded-arglist) + '(&key)) + (mapcar #'encode-keyword-arg + (arglist.keyword-args decoded-arglist)) + (when (arglist.allow-other-keys-p decoded-arglist) + '(&allow-other-keys)) + (when (arglist.any-args decoded-arglist) + `(&any ,@(arglist.any-args decoded-arglist))) + (cond ((not (arglist.rest decoded-arglist)) + '()) + ((arglist.body-p decoded-arglist) + `(&body ,(arglist.rest decoded-arglist))) + (t + `(&rest ,(arglist.rest decoded-arglist)))) + (when (arglist.aux-args decoded-arglist) + `(&aux ,(arglist.aux-args decoded-arglist))) + (arglist.known-junk decoded-arglist) + (arglist.unknown-junk decoded-arglist))) + +;;;; Arglist Enrichment + +(defun arglist-keywords (lambda-list) + "Return the list of keywords in ARGLIST. +As a secondary value, return whether &allow-other-keys appears." + (let ((decoded-arglist (decode-arglist lambda-list))) + (values (arglist.keyword-args decoded-arglist) + (arglist.allow-other-keys-p decoded-arglist)))) + + +(defun methods-keywords (methods) + "Collect all keywords in the arglists of METHODS. +As a secondary value, return whether &allow-other-keys appears somewhere." + (let ((keywords '()) + (allow-other-keys nil)) + (dolist (method methods) + (multiple-value-bind (kw aok) + (arglist-keywords + (slynk-mop:method-lambda-list method)) + (setq keywords (remove-duplicates (append keywords kw) + :key #'keyword-arg.keyword) + allow-other-keys (or allow-other-keys aok)))) + (values keywords allow-other-keys))) + +(defun generic-function-keywords (generic-function) + "Collect all keywords in the methods of GENERIC-FUNCTION. +As a secondary value, return whether &allow-other-keys appears somewhere." + (methods-keywords + (slynk-mop:generic-function-methods generic-function))) + +(defun applicable-methods-keywords (generic-function arguments) + "Collect all keywords in the methods of GENERIC-FUNCTION that are +applicable for argument of CLASSES. As a secondary value, return +whether &allow-other-keys appears somewhere." + (methods-keywords + (multiple-value-bind (amuc okp) + (slynk-mop:compute-applicable-methods-using-classes + generic-function (mapcar #'class-of arguments)) + (if okp + amuc + (compute-applicable-methods generic-function arguments))))) + +(defgeneric extra-keywords (operator args) + (:documentation "Return a list of extra keywords of OPERATOR (a +symbol) when applied to the (unevaluated) ARGS. +As a secondary value, return whether other keys are allowed. +As a tertiary value, return the initial sublist of ARGS that was needed +to determine the extra keywords.")) + +;;; We make sure that symbol-from-KEYWORD-using keywords come before +;;; symbol-from-arbitrary-package-using keywords. And we sort the +;;; latter according to how their home-packages relate to *PACKAGE*. +;;; +;;; Rationale is to show those key parameters first which make most +;;; sense in the current context. And in particular: to put +;;; implementation-internal stuff last. +;;; +;;; This matters tremendeously on Allegro in combination with +;;; AllegroCache as that does some evil tinkering with initargs, +;;; obfuscating the arglist of MAKE-INSTANCE. +;;; + +(defmethod extra-keywords :around (op args) + (declare (ignorable op args)) + (multiple-value-bind (keywords aok enrichments) (call-next-method) + (values (sort-extra-keywords keywords) aok enrichments))) + +(defun make-package-comparator (reference-packages) + "Returns a two-argument test function which compares packages +according to their used-by relation with REFERENCE-PACKAGES. Packages +will be sorted first which appear first in the PACKAGE-USE-LIST of the +reference packages." + (let ((package-use-table (make-hash-table :test 'eq))) + ;; Walk the package dependency graph breadth-fist, and fill + ;; PACKAGE-USE-TABLE accordingly. + (loop with queue = (copy-list reference-packages) + with bfn = 0 ; Breadth-First Number + for p = (pop queue) + unless (gethash p package-use-table) + do (setf (gethash p package-use-table) (shiftf bfn (1+ bfn))) + and do (setf queue (nconc queue (copy-list (package-use-list p)))) + while queue) + #'(lambda (p1 p2) + (let ((bfn1 (gethash p1 package-use-table)) + (bfn2 (gethash p2 package-use-table))) + (cond ((and bfn1 bfn2) (<= bfn1 bfn2)) + (bfn1 bfn1) + (bfn2 nil) ; p2 is used, p1 not + (t (string<= (package-name p1) (package-name p2)))))))) + +(defun sort-extra-keywords (kwds) + (stable-sort kwds (make-package-comparator (list +keyword-package+ *package*)) + :key (compose #'symbol-package #'keyword-arg.keyword))) + +(defun keywords-of-operator (operator) + "Return a list of KEYWORD-ARGs that OPERATOR accepts. +This function is useful for writing EXTRA-KEYWORDS methods for +user-defined functions which are declared &ALLOW-OTHER-KEYS and which +forward keywords to OPERATOR." + (with-available-arglist (arglist) (arglist-from-form (ensure-list operator)) + (values (arglist.keyword-args arglist) + (arglist.allow-other-keys-p arglist)))) + +(defmethod extra-keywords (operator args) + ;; default method + (declare (ignore args)) + (let ((symbol-function (symbol-function operator))) + (if (typep symbol-function 'generic-function) + (generic-function-keywords symbol-function) + nil))) + +(defun class-from-class-name-form (class-name-form) + (when (and (listp class-name-form) + (= (length class-name-form) 2) + (eq (car class-name-form) 'quote)) + (let* ((class-name (cadr class-name-form)) + (class (find-class class-name nil))) + (when (and class + (not (slynk-mop:class-finalized-p class))) + ;; Try to finalize the class, which can fail if + ;; superclasses are not defined yet + (ignore-errors (slynk-mop:finalize-inheritance class))) + class))) + +(defun extra-keywords/slots (class) + (multiple-value-bind (slots allow-other-keys-p) + (if (slynk-mop:class-finalized-p class) + (values (slynk-mop:class-slots class) nil) + (values (slynk-mop:class-direct-slots class) t)) + (let ((slot-init-keywords + (loop for slot in slots append + (mapcar (lambda (initarg) + (make-keyword-arg + initarg + (slynk-mop:slot-definition-name slot) + (and (slynk-mop:slot-definition-initfunction slot) + (slynk-mop:slot-definition-initform slot)))) + (slynk-mop:slot-definition-initargs slot))))) + (values slot-init-keywords allow-other-keys-p)))) + +(defun extra-keywords/make-instance (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (multiple-value-bind (allocate-instance-keywords ai-aokp) + (applicable-methods-keywords + #'allocate-instance (list class)) + (multiple-value-bind (initialize-instance-keywords ii-aokp) + (ignore-errors + (applicable-methods-keywords + #'initialize-instance + (list (slynk-mop:class-prototype class)))) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (slynk-mop:class-prototype class) t))) + (values (append slot-init-keywords + allocate-instance-keywords + initialize-instance-keywords + shared-initialize-keywords) + (or class-aokp ai-aokp ii-aokp si-aokp) + (list class-name-form)))))))))) + +(defun extra-keywords/change-class (operator args) + (declare (ignore operator)) + (unless (null args) + (let* ((class-name-form (car args)) + (class (class-from-class-name-form class-name-form))) + (when class + (multiple-value-bind (slot-init-keywords class-aokp) + (extra-keywords/slots class) + (declare (ignore class-aokp)) + (multiple-value-bind (shared-initialize-keywords si-aokp) + (ignore-errors + (applicable-methods-keywords + #'shared-initialize + (list (slynk-mop:class-prototype class) t))) + ;; FIXME: much as it would be nice to include the + ;; applicable keywords from + ;; UPDATE-INSTANCE-FOR-DIFFERENT-CLASS, I don't really see + ;; how to do it: so we punt, always declaring + ;; &ALLOW-OTHER-KEYS. + (declare (ignore si-aokp)) + (values (append slot-init-keywords shared-initialize-keywords) + t + (list class-name-form)))))))) + +(defmethod extra-keywords ((operator (eql 'make-instance)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'make-condition)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'error)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'signal)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'warn)) + args) + (multiple-value-or (extra-keywords/make-instance operator args) + (call-next-method))) + +(defmethod extra-keywords ((operator (eql 'cerror)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/make-instance operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator (eql 'change-class)) + args) + (multiple-value-bind (keywords aok determiners) + (extra-keywords/change-class operator (cdr args)) + (if keywords + (values keywords aok + (cons (car args) determiners)) + (call-next-method)))) + +(defmethod extra-keywords ((operator symbol) args) + (declare (ignore args)) + (multiple-value-or + (let ((extra-keyword-arglist (get operator :slynk-extra-keywords))) + (when extra-keyword-arglist + (values (loop for (sym default) in extra-keyword-arglist + for keyword = (intern (symbol-name sym) :keyword) + collect (make-keyword-arg keyword + keyword + default)) + (get operator :slynk-allow-other-keywords) + nil))) + (call-next-method))) + + +(defun enrich-decoded-arglist-with-keywords (decoded-arglist keywords + allow-other-keys-p) + "Modify DECODED-ARGLIST using KEYWORDS and ALLOW-OTHER-KEYS-P." + (when keywords + (setf (arglist.key-p decoded-arglist) t) + (setf (arglist.keyword-args decoded-arglist) + (remove-duplicates + (append (arglist.keyword-args decoded-arglist) + keywords) + :key #'keyword-arg.keyword))) + (setf (arglist.allow-other-keys-p decoded-arglist) + (or (arglist.allow-other-keys-p decoded-arglist) + allow-other-keys-p))) + +(defun enrich-decoded-arglist-with-extra-keywords (decoded-arglist form) + "Determine extra keywords from the function call FORM, and modify +DECODED-ARGLIST to include them. As a secondary return value, return +the initial sublist of ARGS that was needed to determine the extra +keywords. As a tertiary return value, return whether any enrichment +was done." + (multiple-value-bind (extra-keywords extra-aok determining-args) + (extra-keywords (car form) (cdr form)) + ;; enrich the list of keywords with the extra keywords + (enrich-decoded-arglist-with-keywords decoded-arglist + extra-keywords extra-aok) + (values decoded-arglist + determining-args + (or extra-keywords extra-aok)))) + +(defgeneric compute-enriched-decoded-arglist (operator-form argument-forms) + (:documentation + "Return three values: DECODED-ARGLIST, DETERMINING-ARGS, and +ANY-ENRICHMENT, just like enrich-decoded-arglist-with-extra-keywords. +If the arglist is not available, return :NOT-AVAILABLE.")) + +(defmethod compute-enriched-decoded-arglist (operator-form argument-forms) + (with-available-arglist (decoded-arglist) + (decode-arglist (arglist operator-form)) + (enrich-decoded-arglist-with-extra-keywords decoded-arglist + (cons operator-form + argument-forms)))) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'with-open-file)) argument-forms) + (declare (ignore argument-forms)) + (multiple-value-bind (decoded-arglist determining-args) + (call-next-method) + (let ((first-arg (first (arglist.required-args decoded-arglist))) + (open-arglist (compute-enriched-decoded-arglist 'open nil))) + (when (and (arglist-p first-arg) (arglist-p open-arglist)) + (enrich-decoded-arglist-with-keywords + first-arg + (arglist.keyword-args open-arglist) + nil))) + (values decoded-arglist determining-args t))) + +(defmethod compute-enriched-decoded-arglist ((operator-form (eql 'apply)) + argument-forms) + (let ((function-name-form (car argument-forms))) + (when (and (listp function-name-form) + (length= function-name-form 2) + (memq (car function-name-form) '(quote function))) + (let ((function-name (cadr function-name-form))) + (when (valid-operator-symbol-p function-name) + (let ((function-arglist + (compute-enriched-decoded-arglist function-name + (cdr argument-forms)))) + (return-from compute-enriched-decoded-arglist + (values + (make-arglist :required-args + (list 'function) + :optional-args + (append + (mapcar #'(lambda (arg) + (make-optional-arg arg nil)) + (arglist.required-args function-arglist)) + (arglist.optional-args function-arglist)) + :key-p + (arglist.key-p function-arglist) + :keyword-args + (arglist.keyword-args function-arglist) + :rest + 'args + :allow-other-keys-p + (arglist.allow-other-keys-p function-arglist)) + (list function-name-form) + t))))))) + (call-next-method)) + +(defmethod compute-enriched-decoded-arglist + ((operator-form (eql 'multiple-value-call)) argument-forms) + (compute-enriched-decoded-arglist 'apply argument-forms)) + +(defun delete-given-args (decoded-arglist args) + "Delete given ARGS from DECODED-ARGLIST." + (macrolet ((pop-or-return (list) + `(if (null ,list) + (return-from do-decoded-arglist) + (pop ,list)))) + (do-decoded-arglist decoded-arglist + (&provided () + (assert (eq (pop-or-return args) + (pop (arglist.provided-args decoded-arglist))))) + (&required () + (pop-or-return args) + (pop (arglist.required-args decoded-arglist))) + (&optional () + (pop-or-return args) + (pop (arglist.optional-args decoded-arglist))) + (&key (keyword) + ;; N.b. we consider a keyword to be given only when the keyword + ;; _and_ a value has been given for it. + (loop for (key value) on args by #'cddr + when (and (eq keyword key) value) + do (setf (arglist.keyword-args decoded-arglist) + (remove keyword (arglist.keyword-args decoded-arglist) + :key #'keyword-arg.keyword)))))) + decoded-arglist) + +(defun remove-given-args (decoded-arglist args) + ;; FIXME: We actually needa deep copy here. + (delete-given-args (copy-arglist decoded-arglist) args)) + +;;;; Arglist Retrieval + +(defun arglist-from-form (form) + (if (null form) + :not-available + (arglist-dispatch (car form) (cdr form)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export 'arglist-dispatch)) +(defgeneric arglist-dispatch (operator arguments) + ;; Default method + (:method (operator arguments) + (unless (and (symbolp operator) (valid-operator-symbol-p operator)) + (return-from arglist-dispatch :not-available)) + (when (equalp (package-name (symbol-package operator)) "closer-mop") + (let ((standard-symbol (or (find-symbol (symbol-name operator) :cl) + (find-symbol (symbol-name operator) :slynk-mop)))) + (when standard-symbol + (return-from arglist-dispatch + (arglist-dispatch standard-symbol arguments))))) + + (multiple-value-bind (decoded-arglist determining-args) + (compute-enriched-decoded-arglist operator arguments) + (with-available-arglist (arglist) decoded-arglist + ;; replace some formal args by determining actual args + (setf arglist (delete-given-args arglist determining-args)) + (setf (arglist.provided-args arglist) determining-args) + arglist)))) + +(defmethod arglist-dispatch ((operator (eql 'defmethod)) arguments) + (match (cons operator arguments) + (('defmethod (#'function-exists-p gf-name) . rest) + (let ((gf (fdefinition gf-name))) + (when (typep gf 'generic-function) + (let ((lambda-list (slynk-mop:generic-function-lambda-list gf))) + (with-available-arglist (arglist) (decode-arglist lambda-list) + (let ((qualifiers (loop for x in rest + until (or (listp x) (empty-arg-p x)) + collect x))) + (return-from arglist-dispatch + (make-arglist :provided-args (cons gf-name qualifiers) + :required-args (list arglist) + :rest "body" :body-p t)))))))) + (_)) ; Fall through + (call-next-method)) + +(defmethod arglist-dispatch ((operator (eql 'define-compiler-macro)) arguments) + (match (cons operator arguments) + (('define-compiler-macro (#'function-exists-p gf-name) . _) + (let ((gf (fdefinition gf-name))) + (with-available-arglist (arglist) (decode-arglist (arglist gf)) + (return-from arglist-dispatch + (make-arglist :provided-args (list gf-name) + :required-args (list arglist) + :rest "body" :body-p t))))) + (_)) ; Fall through + (call-next-method)) + + +(defmethod arglist-dispatch ((operator (eql 'eval-when)) arguments) + (declare (ignore arguments)) + (let ((eval-when-args '(:compile-toplevel :load-toplevel :execute))) + (make-arglist + :required-args (list (make-arglist :any-p t :any-args eval-when-args)) + :rest '#:body :body-p t))) + + +(defmethod arglist-dispatch ((operator (eql 'declare)) arguments) + (let* ((declaration (cons operator (last arguments))) + (typedecl-arglist (arglist-for-type-declaration declaration))) + (if (arglist-available-p typedecl-arglist) + typedecl-arglist + (match declaration + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (('declare (decl-identifier . decl-args)) + (decoded-arglist-for-declaration decl-identifier decl-args)) + (_ (make-arglist :rest '#:declaration-specifiers)))))) + +(defmethod arglist-dispatch ((operator (eql 'declaim)) arguments) + (arglist-dispatch 'declare arguments)) + + +(defun arglist-for-type-declaration (declaration) + (flet ((%arglist-for-type-declaration (identifier typespec rest-var-name) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :provided-args (list identifier) + :required-args (list typespec-arglist) + :rest rest-var-name)))))) + (match declaration + (('declare ('type (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'type typespec '#:variables)) + (('declare ('ftype (#'consp typespec) . decl-args)) + (%arglist-for-type-declaration 'ftype typespec '#:function-names)) + (('declare ((#'consp typespec) . decl-args)) + (with-available-arglist (typespec-arglist) + (decoded-arglist-for-type-specifier typespec) + (make-arglist + :required-args (list (make-arglist + :required-args (list typespec-arglist) + :rest '#:variables))))) + (_ :not-available)))) + +(defun decoded-arglist-for-declaration (decl-identifier decl-args) + (declare (ignore decl-args)) + (with-available-arglist (arglist) + (decode-arglist (declaration-arglist decl-identifier)) + (setf (arglist.provided-args arglist) (list decl-identifier)) + (make-arglist :required-args (list arglist)))) + +(defun decoded-arglist-for-type-specifier (type-specifier) + (etypecase type-specifier + (arglist-dummy :not-available) + (cons (decoded-arglist-for-type-specifier (car type-specifier))) + (symbol + (with-available-arglist (arglist) + (decode-arglist (type-specifier-arglist type-specifier)) + (setf (arglist.provided-args arglist) (list type-specifier)) + arglist)))) + +;;; Slimefuns + +;;; We work on a RAW-FORM, or BUFFER-FORM, which represent the form at +;;; user's point in Emacs. A RAW-FORM looks like +;;; +;;; ("FOO" ("BAR" ...) "QUUX" ("ZURP" SLYNK::%CURSOR-MARKER%)) +;;; +;;; The expression before the cursor marker is the expression where +;;; user's cursor points at. An explicit marker is necessary to +;;; disambiguate between +;;; +;;; ("IF" ("PRED") +;;; ("F" "X" "Y" %CURSOR-MARKER%)) +;;; +;;; and +;;; ("IF" ("PRED") +;;; ("F" "X" "Y") %CURSOR-MARKER%) + +;;; Notice that for a form like (FOO (BAR |) QUUX), where | denotes +;;; user's point, the following should be sent ("FOO" ("BAR" "" +;;; %CURSOR-MARKER%)). Only the forms up to point should be +;;; considered. + +(defslyfun autodoc (raw-form &key print-right-margin) + "Return a list of two elements. +First, a string representing the arglist for the deepest subform in +RAW-FORM that does have an arglist. The highlighted parameter is +wrapped in ===> X <===. + +Second, a boolean value telling whether the returned string can be cached." + (handler-bind ((serious-condition + #'(lambda (c) + (unless (debug-on-slynk-error) + (let ((*print-right-margin* print-right-margin)) + (return-from autodoc + (list :error + (format nil "Arglist Error: \"~A\"" c)))))))) + (with-buffer-syntax () + (multiple-value-bind (form arglist obj-at-cursor form-path) + (find-subform-with-arglist (parse-raw-form raw-form)) + (cond ((boundp-and-interesting obj-at-cursor) + (list (print-variable-to-string obj-at-cursor) nil)) + (t + (list + (with-available-arglist (arglist) arglist + (decoded-arglist-to-string + arglist + :print-right-margin print-right-margin + :operator (car form) + :highlight (form-path-to-arglist-path form-path + form + arglist))) + t))))))) + +(defun boundp-and-interesting (symbol) + (and symbol + (symbolp symbol) + (boundp symbol) + (not (memq symbol '(cl:t cl:nil))) + (not (keywordp symbol)))) + +(defun print-variable-to-string (symbol) + "Return a short description of VARIABLE-NAME, or NIL." + (let ((*print-pretty* t) (*print-level* 4) + (*print-length* 10) (*print-lines* 1) + (*print-readably* nil) + (value (symbol-value symbol))) + (call/truncated-output-to-string + 75 (lambda (s) + (without-printing-errors (:object value :stream s) + (format s "~A ~A~S" symbol "=> " value)))))) + + +(defslyfun complete-form (raw-form) + "Read FORM-STRING in the current buffer package, then complete it + by adding a template for the missing arguments." + ;; We do not catch errors here because COMPLETE-FORM is an + ;; interactive command, not automatically run in the background like + ;; ARGLIST-FOR-ECHO-AREA. + (with-buffer-syntax () + (multiple-value-bind (arglist provided-args) + (find-immediately-containing-arglist (parse-raw-form raw-form)) + (with-available-arglist (arglist) arglist + (decoded-arglist-to-template-string + (delete-given-args arglist + (remove-if #'empty-arg-p provided-args + :from-end t :count 1)) + :prefix "" :suffix ""))))) + +(defparameter +cursor-marker+ '%cursor-marker%) + +(defun find-subform-with-arglist (form) + "Returns four values: + + The appropriate subform of `form' which is closest to the + +CURSOR-MARKER+ and whose operator is valid and has an + arglist. The +CURSOR-MARKER+ is removed from that subform. + + Second value is the arglist. Local function and macro definitions + appearing in `form' into account. + + Third value is the object in front of +CURSOR-MARKER+. + + Fourth value is a form path to that object." + (labels + ((yield-success (form local-ops) + (multiple-value-bind (form obj-at-cursor form-path) + (extract-cursor-marker form) + (values form + (let ((entry (assoc (car form) local-ops :test #'op=))) + (if entry + (decode-arglist (cdr entry)) + (arglist-from-form form))) + obj-at-cursor + form-path))) + (yield-failure () + (values nil :not-available)) + (operator-p (operator local-ops) + (or (and (symbolp operator) (valid-operator-symbol-p operator)) + (assoc operator local-ops :test #'op=))) + (op= (op1 op2) + (cond ((and (symbolp op1) (symbolp op2)) + (eq op1 op2)) + ((and (arglist-dummy-p op1) (arglist-dummy-p op2)) + (string= (arglist-dummy.string-representation op1) + (arglist-dummy.string-representation op2))))) + (grovel-form (form local-ops) + "Descend FORM top-down, always taking the rightest branch, + until +CURSOR-MARKER+." + (assert (listp form)) + (destructuring-bind (operator . args) form + ;; N.b. the user's cursor is at the rightmost, deepest + ;; subform right before +CURSOR-MARKER+. + (let ((last-subform (car (last form))) + (new-ops)) + (cond + ((eq last-subform +cursor-marker+) + (if (operator-p operator local-ops) + (yield-success form local-ops) + (yield-failure))) + ((not (operator-p operator local-ops)) + (grovel-form last-subform local-ops)) + ;; Make sure to pick up the arglists of local + ;; function/macro definitions. + ((setq new-ops (extract-local-op-arglists operator args)) + (multiple-value-or (grovel-form last-subform + (nconc new-ops local-ops)) + (yield-success form local-ops))) + ;; Some typespecs clash with function names, so we make + ;; sure to bail out early. + ((member operator '(cl:declare cl:declaim)) + (yield-success form local-ops)) + ;; Mostly uninteresting, hence skip. + ((memq operator '(cl:quote cl:function)) + (yield-failure)) + (t + (multiple-value-or (grovel-form last-subform local-ops) + (yield-success form local-ops)))))))) + (if (null form) + (yield-failure) + (grovel-form form '())))) + +(defun extract-cursor-marker (form) + "Returns three values: normalized `form' without +CURSOR-MARKER+, +the object in front of +CURSOR-MARKER+, and a form path to that +object." + (labels ((grovel (form last path) + (let ((result-form)) + (loop for (car . cdr) on form do + (cond ((eql car +cursor-marker+) + (decf (first path)) + (return-from grovel + (values (nreconc result-form cdr) + last + (nreverse path)))) + ((consp car) + (multiple-value-bind (new-car new-last new-path) + (grovel car last (cons 0 path)) + (when new-path ; CAR contained cursor-marker? + (return-from grovel + (values (nreconc + (cons new-car result-form) cdr) + new-last + new-path)))))) + (push car result-form) + (setq last car) + (incf (first path)) + finally + (return-from grovel + (values (nreverse result-form) nil nil)))))) + (grovel form nil (list 0)))) + +(defgeneric extract-local-op-arglists (operator args) + (:documentation + "If the form `(OPERATOR ,@ARGS) is a local operator binding form, + return a list of pairs (OP . ARGLIST) for each locally bound op.") + (:method (operator args) + (declare (ignore operator args)) + nil) + ;; FLET + (:method ((operator (eql 'cl:flet)) args) + (let ((defs (first args)) + (body (rest args))) + (cond ((null body) nil) ; `(flet ((foo (x) |' + ((atom defs) nil) ; `(flet ,foo (|' + (t (%collect-op/argl-alist defs))))) + ;; LABELS + (:method ((operator (eql 'cl:labels)) args) + ;; Notice that we only have information to "look backward" and + ;; show arglists of previously occuring local functions. + (destructuring-bind (defs . body) args + (unless (or (atom defs) (null body)) ; `(labels ,foo (|' + (let ((current-def (car (last defs)))) + (cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|' + ((not (null body)) + (extract-local-op-arglists 'cl:flet args)) + (t + (let ((def.body (cddr current-def))) + (when def.body + (%collect-op/argl-alist defs))))))))) + ;; MACROLET + (:method ((operator (eql 'cl:macrolet)) args) + (extract-local-op-arglists 'cl:labels args))) + +(defun %collect-op/argl-alist (defs) + (setq defs (remove-if-not #'(lambda (x) + ;; Well-formed FLET/LABELS def? + (and (consp x) (second x))) + defs)) + (loop for (name arglist . nil) in defs + collect (cons name arglist))) + +(defun find-immediately-containing-arglist (form) + "Returns the arglist of the subform _immediately_ containing ++CURSOR-MARKER+ in `form'. Notice, however, that +CURSOR-MARKER+ may +be in a nested arglist \(e.g. `(WITH-OPEN-FILE ('\), and the +arglist of the appropriate parent form \(WITH-OPEN-FILE\) will be +returned in that case." + (flet ((try (form-path form arglist) + (let* ((arglist-path (form-path-to-arglist-path form-path + form + arglist)) + (argl (apply #'arglist-ref + arglist + arglist-path)) + (args (apply #'provided-arguments-ref + (cdr form) + arglist + arglist-path))) + (when (and (arglist-p argl) (listp args)) + (values argl args))))) + (multiple-value-bind (form arglist obj form-path) + (find-subform-with-arglist form) + (declare (ignore obj)) + (with-available-arglist (arglist) arglist + ;; First try the form the cursor is in (in case of a normal + ;; form), then try the surrounding form (in case of a nested + ;; macro form). + (multiple-value-or (try form-path form arglist) + (try (butlast form-path) form arglist) + :not-available))))) + +(defun form-path-to-arglist-path (form-path form arglist) + "Convert a form path to an arglist path consisting of arglist +indices." + (labels ((convert (path args arglist) + (if (null path) + nil + (let* ((idx (car path)) + (idx* (arglist-index idx args arglist)) + (arglist* (and idx* (arglist-ref arglist idx*))) + (args* (and idx* (provided-arguments-ref args + arglist + idx*)))) + ;; The FORM-PATH may be more detailed than ARGLIST; + ;; consider (defun foo (x y) ...), a form path may + ;; point into the function's lambda-list, but the + ;; arglist of DEFUN won't contain as much information. + ;; So we only recurse if possible. + (cond ((null idx*) + nil) + ((arglist-p arglist*) + (cons idx* (convert (cdr path) args* arglist*))) + (t + (list idx*))))))) + (convert + ;; FORM contains irrelevant operator. Adjust FORM-PATH. + (cond ((null form-path) nil) + ((equal form-path '(0)) nil) + (t + (destructuring-bind (car . cdr) form-path + (cons (1- car) cdr)))) + (cdr form) + arglist))) + +(defun arglist-index (provided-argument-index provided-arguments arglist) + "Return the arglist index into `arglist' for the parameter belonging +to the argument (NTH `provided-argument-index' `provided-arguments')." + (let ((positional-args# (positional-args-number arglist)) + (arg-index provided-argument-index)) + (with-struct (arglist. key-p rest) arglist + (cond + ((< arg-index positional-args#) ; required + optional + arg-index) + ((and (not key-p) (not rest)) ; more provided than allowed + nil) + ((not key-p) ; rest + body + (assert (arglist.rest arglist)) + positional-args#) + (t ; key + ;; Find last provided &key parameter + (let* ((argument (nth arg-index provided-arguments)) + (provided-keys (subseq provided-arguments positional-args#))) + (loop for (key value) on provided-keys by #'cddr + when (eq value argument) + return (match key + (('quote symbol) symbol) + (_ key))))))))) + +(defun arglist-ref (arglist &rest indices) + "Returns the parameter in ARGLIST along the INDICIES path. Numbers +represent positional parameters (required, optional), keywords +represent key parameters." + (flet ((ref-positional-arg (arglist index) + (check-type index (integer 0 *)) + (with-struct (arglist. provided-args required-args + optional-args rest) + arglist + (loop for args in (list provided-args required-args + (mapcar #'optional-arg.arg-name + optional-args)) + for args# = (length args) + if (< index args#) + return (nth index args) + else + do (decf index args#) + finally (return (or rest nil))))) + (ref-keyword-arg (arglist keyword) + ;; keyword argument may be any symbol, + ;; not only from the KEYWORD package. + (let ((keyword (match keyword + (('quote symbol) symbol) + (_ keyword)))) + (do-decoded-arglist arglist + (&key (kw arg) (when (eq kw keyword) + (return-from ref-keyword-arg arg))))) + nil)) + (dolist (index indices) + (assert (arglist-p arglist)) + (setq arglist (if (numberp index) + (ref-positional-arg arglist index) + (ref-keyword-arg arglist index)))) + arglist)) + +(defun provided-arguments-ref (provided-args arglist &rest indices) + "Returns the argument in PROVIDED-ARGUMENT along the INDICES path +relative to ARGLIST." + (check-type arglist arglist) + (flet ((ref (provided-args arglist index) + (if (numberp index) + (nth index provided-args) + (let ((provided-keys (subseq provided-args + (positional-args-number arglist)))) + (loop for (key value) on provided-keys + when (eq key index) + return value))))) + (dolist (idx indices) + (setq provided-args (ref provided-args arglist idx)) + (setq arglist (arglist-ref arglist idx))) + provided-args)) + +(defun positional-args-number (arglist) + (+ (length (arglist.provided-args arglist)) + (length (arglist.required-args arglist)) + (length (arglist.optional-args arglist)))) + +(defun parse-raw-form (raw-form) + "Parse a RAW-FORM into a Lisp form. I.e. substitute strings by +symbols if already interned. For strings not already interned, use +ARGLIST-DUMMY." + (unless (null raw-form) + (loop for element in raw-form + collect (etypecase element + (string (read-conversatively element)) + (list (parse-raw-form element)) + (symbol (prog1 element + ;; Comes after list, so ELEMENT can't be NIL. + (assert (eq element +cursor-marker+)))))))) + +(defun read-conversatively (string) + "Tries to find the symbol that's represented by STRING. + +If it can't, this either means that STRING does not represent a +symbol, or that the symbol behind STRING would have to be freshly +interned. Because this function is supposed to be called from the +automatic arglist display stuff from Slime, interning freshly +symbols is a big no-no. + +In such a case (that no symbol could be found), an object of type +ARGLIST-DUMMY is returned instead, which works as a placeholder +datum for subsequent logics to rely on." + (let* ((string (string-left-trim '(#\Space #\Tab #\Newline) string)) + (length (length string)) + (type (cond ((zerop length) nil) + ((eql (aref string 0) #\') + :quoted-symbol) + ((search "#'" string :end2 (min length 2)) + :sharpquoted-symbol) + ((char= (char string 0) (char string (1- length)) + #\") + :string) + (t + :symbol)))) + (multiple-value-bind (symbol found?) + (case type + (:symbol (parse-symbol string)) + (:quoted-symbol (parse-symbol (subseq string 1))) + (:sharpquoted-symbol (parse-symbol (subseq string 2))) + (:string (values string t)) + (t (values string nil))) + (if found? + (ecase type + (:symbol symbol) + (:quoted-symbol `(quote ,symbol)) + (:sharpquoted-symbol `(function ,symbol)) + (:string (if (> length 1) + (subseq string 1 (1- length)) + string))) + (make-arglist-dummy string))))) + +(defun test-print-arglist () + (flet ((test (arglist &rest strings) + (let* ((*package* (find-package :slynk)) + (actual (decoded-arglist-to-string + (decode-arglist arglist) + :print-right-margin 1000))) + (unless (loop for string in strings + thereis (string= actual string)) + (warn "Test failed: ~S => ~S~% Expected: ~A" + arglist actual + (if (cdr strings) + (format nil "One of: ~{~S~^, ~}" strings) + (format nil "~S" (first strings)))))))) + (test '(function cons) "(function cons)") + (test '(quote cons) "(quote cons)") + (test '(&key (function #'+)) + "(&key (function #'+))" "(&key (function (function +)))") + (test '(&whole x y z) "(y z)") + (test '(x &aux y z) "(x)") + (test '(x &environment env y) "(x y)") + (test '(&key ((function f))) "(&key ((function ..)))") + (test + '(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body) + "(eval-when (&any :compile-toplevel :load-toplevel :execute) &body body)") + (test '(declare (optimize &any (speed 1) (safety 1))) + "(declare (optimize &any (speed 1) (safety 1)))"))) + +(defun test-arglist-ref () + (macrolet ((soft-assert (form) + `(unless ,form + (warn "Assertion failed: ~S~%" ',form)))) + (let ((sample (decode-arglist '(x &key ((:k (y z))))))) + (soft-assert (eq (arglist-ref sample 0) 'x)) + (soft-assert (eq (arglist-ref sample :k 0) 'y)) + (soft-assert (eq (arglist-ref sample :k 1) 'z)) + + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample 0) + 'a)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 0) + 'b)) + (soft-assert (eq (provided-arguments-ref '(a :k (b c)) sample :k 1) + 'c))))) + +(test-print-arglist) +(test-arglist-ref) + +(provide :slynk/arglists) blob - /dev/null blob + 7b0c79aa73bfe374b3d65c21e64448f7baa95487 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-fancy-inspector.lisp @@ -0,0 +1,1034 @@ +;;; slynk-fancy-inspector.lisp --- Fancy inspector for CLOS objects +;; +;; Author: Marco Baringer and others +;; License: Public Domain +;; + +(in-package :slynk) + +(defmethod emacs-inspect ((symbol symbol)) + (let ((package (symbol-package symbol))) + (multiple-value-bind (_symbol status) + (and package (find-symbol (string symbol) package)) + (declare (ignore _symbol)) + (append + (label-value-line "Its name is" (symbol-name symbol)) + ;; + ;; Value + (cond ((boundp symbol) + (append + (label-value-line (if (constantp symbol) + "It is a constant of value" + "It is a global variable bound to") + (symbol-value symbol) :newline nil) + ;; unbinding constants might be not a good idea, but + ;; implementations usually provide a restart. + `(" " (:action "[unbind]" + ,(lambda () (makunbound symbol)))) + '((:newline)))) + (t '("It is unbound." (:newline)))) + (docstring-ispec "Documentation" symbol 'variable) + (multiple-value-bind (expansion definedp) (macroexpand symbol) + (if definedp + (label-value-line "It is a symbol macro with expansion" + expansion))) + ;; + ;; Function + (if (fboundp symbol) + (append (if (macro-function symbol) + `("It a macro with macro-function: " + (:value ,(macro-function symbol))) + `("It is a function: " + (:value ,(symbol-function symbol)))) + `(" " (:action "[unbind]" + ,(lambda () (fmakunbound symbol)))) + `((:newline))) + `("It has no function value." (:newline))) + (docstring-ispec "Function documentation" symbol 'function) + (when (compiler-macro-function symbol) + (append + (label-value-line "It also names the compiler macro" + (compiler-macro-function symbol) :newline nil) + `(" " (:action "[remove]" + ,(lambda () + (setf (compiler-macro-function symbol) nil))) + (:newline)))) + (docstring-ispec "Compiler macro documentation" + symbol 'compiler-macro) + ;; + ;; Package + (if package + `("It is " ,(string-downcase (string status)) + " to the package: " + (:value ,package ,(package-name package)) + ,@(if (eq :internal status) + `(" " + (:action "[export]" + ,(lambda () (export symbol package))))) + " " + (:action "[unintern]" + ,(lambda () (unintern symbol package))) + (:newline)) + '("It is a non-interned symbol." (:newline))) + ;; + ;; Plist + (label-value-line "Property list" (symbol-plist symbol)) + ;; + ;; Class + (if (find-class symbol nil) + `("It names the class " + (:value ,(find-class symbol) ,(string symbol)) + " " + (:action "[remove]" + ,(lambda () (setf (find-class symbol) nil))) + (:newline))) + ;; + ;; More package + (if (find-package symbol) + (label-value-line "It names the package" (find-package symbol))) + (inspect-type-specifier symbol))))) + +#-sbcl +(defun inspect-type-specifier (symbol) + (declare (ignore symbol))) + +#+sbcl +(defun inspect-type-specifier (symbol) + (let* ((kind (sb-int:info :type :kind symbol)) + (fun (case kind + (:defined + (or (sb-int:info :type :expander symbol) t)) + (:primitive + (or #.(if (slynk-sbcl::sbcl-version>= 1 3 1) + '(let ((x (sb-int:info :type :expander symbol))) + (if (consp x) + (car x) + x)) + '(sb-int:info :type :translator symbol)) + t))))) + (when fun + (append + (list + (format nil "It names a ~@[primitive~* ~]type-specifier." + (eq kind :primitive)) + '(:newline)) + (docstring-ispec "Type-specifier documentation" symbol 'type) + (unless (eq t fun) + (let ((arglist (arglist fun))) + (append + `("Type-specifier lambda-list: " + ;; Could use ~:s, but inspector-princ does a bit more, + ;; and not all NILs in the arglist should be printed that way. + ,(if arglist + (inspector-princ arglist) + "()") + (:newline)) + (multiple-value-bind (expansion ok) + (handler-case (sb-ext:typexpand-1 symbol) + (error () (values nil nil))) + (when ok + (list "Type-specifier expansion: " + (princ-to-string expansion))))))))))) + +(defun docstring-ispec (label object kind) + "Return a inspector spec if OBJECT has a docstring of kind KIND." + (let ((docstring (documentation object kind))) + (cond ((not docstring) nil) + ((< (+ (length label) (length docstring)) + 75) + (list label ": " docstring '(:newline))) + (t + (list label ":" '(:newline) " " docstring '(:newline)))))) + +(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) + (defmethod emacs-inspect ((f function)) + (inspect-function f))) + +(defun inspect-function (f) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(inspector-princ (arglist f)) (:newline)) + (docstring-ispec "Documentation" f t) + (if (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))))) + +(defun method-specializers-for-inspect (method) + "Return a \"pretty\" list of the method's specializers. Normal + specializers are replaced by the name of the class, eql + specializers are replaced by `(eql ,object)." + (mapcar (lambda (spec) + (typecase spec + (slynk-mop:eql-specializer + `(eql ,(slynk-mop:eql-specializer-object spec))) + #-sbcl + (t + (slynk-mop:class-name spec)) + #+sbcl + (t + ;; SBCL has extended specializers + (let ((gf (sb-mop:method-generic-function method))) + (cond (gf + (sb-pcl:unparse-specializer-using-class gf spec)) + ((typep spec 'class) + (class-name spec)) + (t + spec)))))) + (slynk-mop:method-specializers method))) + +(defun method-for-inspect-value (method) + "Returns a \"pretty\" list describing METHOD. The first element + of the list is the name of generic-function method is + specialiazed on, the second element is the method qualifiers, + the rest of the list is the method's specialiazers (as per + method-specializers-for-inspect)." + (append (list (slynk-mop:generic-function-name + (slynk-mop:method-generic-function method))) + (slynk-mop:method-qualifiers method) + (method-specializers-for-inspect method))) + +(defmethod emacs-inspect ((object standard-object)) + (let ((class (class-of object))) + `("Class: " (:value ,class) (:newline) + ,@(all-slots-for-inspector object)))) + +(defvar *gf-method-getter* 'methods-by-applicability + "This function is called to get the methods of a generic function. +The default returns the method sorted by applicability. +See `methods-by-applicability'.") + +(defun specializer< (specializer1 specializer2) + "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." + (let ((s1 specializer1) (s2 specializer2) ) + (cond ((typep s1 'slynk-mop:eql-specializer) + (not (typep s2 'slynk-mop:eql-specializer))) + ((typep s1 'class) + (flet ((cpl (class) + (and (slynk-mop:class-finalized-p class) + (slynk-mop:class-precedence-list class)))) + (member s2 (cpl s1))))))) + +(defun methods-by-applicability (gf) + "Return methods ordered by most specific argument types. + +`method-specializer<' is used for sorting." + ;; FIXME: argument-precedence-order and qualifiers are ignored. + (labels ((method< (meth1 meth2) + (loop for s1 in (slynk-mop:method-specializers meth1) + for s2 in (slynk-mop:method-specializers meth2) + do (cond ((specializer< s2 s1) (return nil)) + ((specializer< s1 s2) (return t)))))) + (stable-sort (copy-seq (slynk-mop:generic-function-methods gf)) + #'method<))) + +(defun abbrev-doc (doc &optional (maxlen 80)) + "Return the first sentence of DOC, but not more than MAXLAN characters." + (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) + maxlen + (length doc)))) + +(defstruct (inspector-checklist (:conc-name checklist.) + (:constructor %make-checklist (buttons))) + (buttons nil :type (or null simple-vector)) + (count 0)) + +(defun make-checklist (n) + (%make-checklist (make-array n :initial-element nil))) + +(defun reinitialize-checklist (checklist) + ;; Along this counter the buttons are created, so we have to + ;; initialize it to 0 everytime the inspector page is redisplayed. + (setf (checklist.count checklist) 0) + checklist) + +(defun make-checklist-button (checklist) + (let ((buttons (checklist.buttons checklist)) + (i (checklist.count checklist))) + (incf (checklist.count checklist)) + `(:action ,(if (svref buttons i) + "[X]" + "[ ]") + ,#'(lambda () + (setf (svref buttons i) (not (svref buttons i)))) + :refreshp t))) + +(defmacro do-checklist ((idx checklist) &body body) + "Iterate over all set buttons in CHECKLIST." + (let ((buttons (gensym "buttons"))) + `(let ((,buttons (checklist.buttons ,checklist))) + (dotimes (,idx (length ,buttons)) + (when (svref ,buttons ,idx) + ,@body))))) + +(defun box (thing) (cons :box thing)) +(defun ref (box) + (assert (eq (car box) :box)) + (cdr box)) +(defun (setf ref) (value box) + (assert (eq (car box) :box)) + (setf (cdr box) value)) + +(defvar *inspector-slots-default-order* :alphabetically + "Accepted values: :alphabetically and :unsorted") + +(defvar *inspector-slots-default-grouping* :all + "Accepted values: :inheritance and :all") + +(defgeneric all-slots-for-inspector (object)) + +(defmethod all-slots-for-inspector ((object standard-object)) + (let* ((class (class-of object)) + (direct-slots (slynk-mop:class-direct-slots class)) + (effective-slots (slynk-mop:class-slots class)) + (longest-slot-name-length + (loop for slot :in effective-slots + maximize (length (symbol-name + (slynk-mop:slot-definition-name slot))))) + (checklist + (reinitialize-checklist + (ensure-istate-metadata object :checklist + (make-checklist (length effective-slots))))) + (grouping-kind + ;; We box the value so we can re-set it. + (ensure-istate-metadata object :grouping-kind + (box *inspector-slots-default-grouping*))) + (sort-order + (ensure-istate-metadata object :sort-order + (box *inspector-slots-default-order*))) + (sort-predicate (ecase (ref sort-order) + (:alphabetically #'string<) + (:unsorted (constantly nil)))) + (sorted-slots (sort (copy-seq effective-slots) + sort-predicate + :key #'slynk-mop:slot-definition-name)) + (effective-slots + (ecase (ref grouping-kind) + (:all sorted-slots) + (:inheritance (stable-sort-by-inheritance sorted-slots + class sort-predicate))))) + `("--------------------" + (:newline) + " Group slots by inheritance " + (:action ,(ecase (ref grouping-kind) + (:all "[ ]") + (:inheritance "[X]")) + ,(lambda () + ;; We have to do this as the order of slots will + ;; be sorted differently. + (fill (checklist.buttons checklist) nil) + (setf (ref grouping-kind) + (ecase (ref grouping-kind) + (:all :inheritance) + (:inheritance :all)))) + :refreshp t) + (:newline) + " Sort slots alphabetically " + (:action ,(ecase (ref sort-order) + (:unsorted "[ ]") + (:alphabetically "[X]")) + ,(lambda () + (fill (checklist.buttons checklist) nil) + (setf (ref sort-order) + (ecase (ref sort-order) + (:unsorted :alphabetically) + (:alphabetically :unsorted)))) + :refreshp t) + (:newline) + ,@ (case (ref grouping-kind) + (:all + `((:newline) + "All Slots:" + (:newline) + ,@(make-slot-listing checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:inheritance + (list-all-slots-by-inheritance checklist object class + effective-slots direct-slots + longest-slot-name-length))) + (:newline) + (:action "[set value]" + ,(lambda () + (do-checklist (idx checklist) + (query-and-set-slot class object + (nth idx effective-slots)))) + :refreshp t) + " " + (:action "[make unbound]" + ,(lambda () + (do-checklist (idx checklist) + (slynk-mop:slot-makunbound-using-class + class object (nth idx effective-slots)))) + :refreshp t) + (:newline)))) + +(defun list-all-slots-by-inheritance (checklist object class effective-slots + direct-slots longest-slot-name-length) + (flet ((slot-home-class (slot) + (slot-home-class-using-class slot class))) + (let ((current-slots '())) + (append + (loop for slot in effective-slots + for previous-home-class = (slot-home-class slot) then home-class + for home-class = previous-home-class then (slot-home-class slot) + if (eq home-class previous-home-class) + do (push slot current-slots) + else + collect '(:newline) + and collect (format nil "~A:" (class-name previous-home-class)) + and collect '(:newline) + and append (make-slot-listing checklist object class + (nreverse current-slots) + direct-slots + longest-slot-name-length) + and do (setf current-slots (list slot))) + (and current-slots + `((:newline) + ,(format nil "~A:" + (class-name (slot-home-class-using-class + (car current-slots) class))) + (:newline) + ,@(make-slot-listing checklist object class + (nreverse current-slots) direct-slots + longest-slot-name-length))))))) + +(defun make-slot-listing (checklist object class effective-slots direct-slots + longest-slot-name-length) + (flet ((padding-for (slot-name) + (make-string (- longest-slot-name-length (length slot-name)) + :initial-element #\Space))) + (loop + for effective-slot :in effective-slots + for direct-slot = (find (slynk-mop:slot-definition-name effective-slot) + direct-slots + :key #'slynk-mop:slot-definition-name) + for slot-name = (inspector-princ + (slynk-mop:slot-definition-name effective-slot)) + collect (make-checklist-button checklist) + collect " " + collect `(:value ,(if direct-slot + (list direct-slot effective-slot) + effective-slot) + ,slot-name) + collect (padding-for slot-name) + collect " = " + collect (slot-value-for-inspector class object effective-slot) + collect '(:newline)))) + +(defgeneric slot-value-for-inspector (class object slot) + (:method (class object slot) + (let ((boundp (slynk-mop:slot-boundp-using-class class object slot))) + (if boundp + `(:value ,(slynk-mop:slot-value-using-class class object slot)) + "#")))) + +(defun slot-home-class-using-class (slot class) + (let ((slot-name (slynk-mop:slot-definition-name slot))) + (loop for class in (reverse (slynk-mop:class-precedence-list class)) + thereis (and (member slot-name (slynk-mop:class-direct-slots class) + :key #'slynk-mop:slot-definition-name + :test #'eq) + class)))) + +(defun stable-sort-by-inheritance (slots class predicate) + (stable-sort slots predicate + :key #'(lambda (s) + (class-name (slot-home-class-using-class s class))))) + +(defun query-and-set-slot (class object slot) + (let* ((slot-name (slynk-mop:slot-definition-name slot)) + (value-string (read-from-minibuffer-in-emacs + (format nil "Set slot ~S to (evaluated) : " + slot-name)))) + (when (and value-string (not (string= value-string ""))) + (with-simple-restart (abort "Abort setting slot ~S" slot-name) + (setf (slynk-mop:slot-value-using-class class object slot) + (eval (read-from-string value-string))))))) + + +(defmethod emacs-inspect ((gf standard-generic-function)) + (flet ((lv (label value) (label-value-line label value))) + (append + (lv "Name" (slynk-mop:generic-function-name gf)) + (lv "Arguments" (slynk-mop:generic-function-lambda-list gf)) + (docstring-ispec "Documentation" gf t) + (lv "Method class" (slynk-mop:generic-function-method-class gf)) + (lv "Method combination" + (slynk-mop:generic-function-method-combination gf)) + `("Methods: " (:newline)) + (loop for method in (funcall *gf-method-getter* gf) append + `((:value ,method ,(inspector-princ + ;; drop the name of the GF + (cdr (method-for-inspect-value method)))) + " " + (:action "[remove method]" + ,(let ((m method)) ; LOOP reassigns method + (lambda () + (remove-method gf m)))) + (:newline))) + `((:newline)) + (all-slots-for-inspector gf)))) + +(defmethod emacs-inspect ((method standard-method)) + `(,@(if (slynk-mop:method-generic-function method) + `("Method defined on the generic function " + (:value ,(slynk-mop:method-generic-function method) + ,(inspector-princ + (slynk-mop:generic-function-name + (slynk-mop:method-generic-function method))))) + '("Method without a generic function")) + (:newline) + ,@(docstring-ispec "Documentation" method t) + "Lambda List: " (:value ,(slynk-mop:method-lambda-list method)) + (:newline) + "Specializers: " (:value ,(slynk-mop:method-specializers method) + ,(inspector-princ + (method-specializers-for-inspect method))) + (:newline) + "Qualifiers: " (:value ,(slynk-mop:method-qualifiers method)) + (:newline) + "Method function: " (:value ,(slynk-mop:method-function method)) + (:newline) + ,@(all-slots-for-inspector method))) + +(defun specializer-direct-methods (class) + (sort (copy-seq (slynk-mop:specializer-direct-methods class)) + #'string< + :key + (lambda (x) + (symbol-name + (let ((name (slynk-mop::generic-function-name + (slynk-mop::method-generic-function x)))) + (if (symbolp name) + name + (second name))))))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(common-seperated-spec (slynk-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(common-seperated-spec + (slynk-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (slynk-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (slynk-mop:class-finalized-p class) + (common-seperated-spec + (slynk-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(inspector-princ + (slynk-mop:slot-definition-name slot))))) + `("# " + (:action "[finalize]" + ,(lambda () (slynk-mop:finalize-inheritance class))))) + (:newline) + ,@(let ((doc (documentation class t))) + (when doc + `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) + "Sub classes: " + ,@(common-seperated-spec (slynk-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub + ,(inspector-princ (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (slynk-mop:class-finalized-p class) + (common-seperated-spec + (slynk-mop:class-precedence-list class) + (lambda (class) + `(:value ,class ,(inspector-princ (class-name class))))) + '("#")) + (:newline) + ,@(when (slynk-mop:specializer-direct-methods class) + `("It is used as a direct specializer in the following methods:" + (:newline) + ,@(loop + for method in (specializer-direct-methods class) + collect " " + collect `(:value ,method + ,(inspector-princ + (method-for-inspect-value method))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (abbrev-doc (documentation method t)) and + collect '(:newline)))) + "Prototype: " ,(if (slynk-mop:class-finalized-p class) + `(:value ,(slynk-mop:class-prototype class)) + '"#") + (:newline) + ,@(all-slots-for-inspector class))) + +(defmethod emacs-inspect ((slot slynk-mop:standard-slot-definition)) + `("Name: " + (:value ,(slynk-mop:slot-definition-name slot)) + (:newline) + ,@(when (slynk-mop:slot-definition-documentation slot) + `("Documentation:" (:newline) + (:value ,(slynk-mop:slot-definition-documentation + slot)) + (:newline))) + "Init args: " + (:value ,(slynk-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (slynk-mop:slot-definition-initfunction slot) + `(:value ,(slynk-mop:slot-definition-initform slot)) + "#") + (:newline) + "Init function: " + (:value ,(slynk-mop:slot-definition-initfunction slot)) + (:newline) + ,@(all-slots-for-inspector slot))) + + +;; Wrapper structure over the list of symbols of a package that should +;; be displayed with their respective classification flags. This is +;; because we need a unique type to dispatch on in EMACS-INSPECT. +;; Used by the Inspector for packages. +(defstruct (%package-symbols-container + (:conc-name %container.) + (:constructor %%make-package-symbols-container)) + title ;; A string; the title of the inspector page in Emacs. + description ;; A list of renderable objects; used as description. + symbols ;; A list of symbols. Supposed to be sorted alphabetically. + grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING + + +(defun %make-package-symbols-container (&key title description symbols) + (%%make-package-symbols-container :title title :description description + :symbols symbols :grouping-kind :symbol)) + +(defun symbol-classification-string (symbol) + "Return a string in the form -f-c---- where each letter stands for +boundp fboundp generic-function class macro special-operator package" + (let ((letters "bfgctmsp") + (result (copy-seq "--------"))) + (flet ((flip (letter) + (setf (char result (position letter letters)) + letter))) + (when (boundp symbol) (flip #\b)) + (when (fboundp symbol) + (flip #\f) + (when (typep (ignore-errors (fdefinition symbol)) + 'generic-function) + (flip #\g))) + (when (type-specifier-p symbol) (flip #\t)) + (when (find-class symbol nil) (flip #\c) ) + (when (macro-function symbol) (flip #\m)) + (when (special-operator-p symbol) (flip #\s)) + (when (find-package symbol) (flip #\p)) + result))) + +(defgeneric make-symbols-listing (grouping-kind symbols)) + +(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) + "Returns an object renderable by Emacs' inspector side that +alphabetically lists all the symbols in SYMBOLS together with a +concise string representation of what each symbol +represents (see SYMBOL-CLASSIFICATION-STRING)" + (let ((max-length (loop for s in symbols + maximizing (length (symbol-name s)))) + (distance 10)) ; empty distance between name and classification + (flet ((string-representations (symbol) + (let* ((name (symbol-name symbol)) + (length (length name)) + (padding (- max-length length))) + (values + (concatenate 'string + name + (make-string (+ padding distance) + :initial-element #\Space)) + (symbol-classification-string symbol))))) + `("" ; 8 is (length "Symbols:") + "Symbols:" ,(make-string (+ -8 max-length distance) + :initial-element #\Space) + "Flags:" + (:newline) + ,(concatenate 'string ; underlining dashes + (make-string (+ max-length distance -1) + :initial-element #\-) + " " + (symbol-classification-string '#:foo)) + (:newline) + ,@(loop for symbol in symbols appending + (multiple-value-bind (symbol-string classification-string) + (string-representations symbol) + `((:value ,symbol ,symbol-string) ,classification-string + (:newline) + ))))))) + +(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) + "For each possible classification (cf. CLASSIFY-SYMBOL), group +all the symbols in SYMBOLS to all of their respective +classifications. (If a symbol is, for instance, boundp and a +generic-function, it'll appear both below the BOUNDP group and +the GENERIC-FUNCTION group.) As macros and special-operators are +specified to be FBOUNDP, there is no general FBOUNDP group, +instead there are the three explicit FUNCTION, MACRO and +SPECIAL-OPERATOR groups." + (let ((table (make-hash-table :test #'eq)) + (+default-classification+ :misc)) + (flet ((normalize-classifications (classifications) + (cond ((null classifications) `(,+default-classification+)) + ;; Convert an :FBOUNDP in CLASSIFICATIONS to + ;; :FUNCTION if possible. + ((and (member :fboundp classifications) + (not (member :macro classifications)) + (not (member :special-operator classifications))) + (substitute :function :fboundp classifications)) + (t (remove :fboundp classifications))))) + (loop for symbol in symbols do + (loop for classification in + (normalize-classifications (classify-symbol symbol)) + ;; SYMBOLS are supposed to be sorted alphabetically; + ;; this property is preserved here except for reversing. + do (push symbol (gethash classification table))))) + (let* ((classifications (loop for k being each hash-key in table + collect k)) + (classifications (sort classifications + ;; Sort alphabetically, except + ;; +DEFAULT-CLASSIFICATION+ which + ;; sort to the end. + (lambda (a b) + (cond ((eql a +default-classification+) + nil) + ((eql b +default-classification+) + t) + (t (string< a b))))))) + (loop for classification in classifications + for symbols = (gethash classification table) + appending`(,(symbol-name classification) + (:newline) + ,(make-string 64 :initial-element #\-) + (:newline) + ,@(mapcan (lambda (symbol) + `((:value ,symbol ,(symbol-name symbol)) + (:newline))) + ;; restore alphabetic order. + (nreverse symbols)) + (:newline)))))) + +(defmethod emacs-inspect ((%container %package-symbols-container)) + (with-struct (%container. title description symbols grouping-kind) %container + `(,title (:newline) (:newline) + ,@description + (:newline) + " " ,(ecase grouping-kind + (:symbol + `(:action "[Group by classification]" + ,(lambda () + (setf grouping-kind :classification)) + :refreshp t)) + (:classification + `(:action "[Group by symbol]" + ,(lambda () (setf grouping-kind :symbol)) + :refreshp t))) + (:newline) (:newline) + ,@(make-symbols-listing grouping-kind symbols)))) + +(defun display-link (type symbols length &key title description) + (if (null symbols) + (format nil "0 ~A symbols." type) + `(:value ,(%make-package-symbols-container :title title + :description description + :symbols symbols) + ,(format nil "~D ~A symbol~P." length type length)))) + +(defmacro do-symbols* ((var &optional (package '*package*) result-form) + &body body) + "Just like do-symbols, but makes sure a symbol is visited only once." + (let ((seen-ht (gensym "SEEN-HT"))) + `(let ((,seen-ht (make-hash-table :test #'eq))) + (do-symbols (,var ,package ,result-form) + (unless (gethash ,var ,seen-ht) + (setf (gethash ,var ,seen-ht) t) + (tagbody ,@body)))))) + +(defmethod emacs-inspect ((package package)) + (let ((package-name (package-name package)) + (package-nicknames (package-nicknames package)) + (package-use-list (package-use-list package)) + (package-used-by-list (package-used-by-list package)) + (shadowed-symbols (package-shadowing-symbols package)) + (present-symbols '()) (present-symbols-length 0) + (internal-symbols '()) (internal-symbols-length 0) + (inherited-symbols '()) (inherited-symbols-length 0) + (external-symbols '()) (external-symbols-length 0)) + + (do-symbols* (sym package) + (let ((status (symbol-status sym package))) + (when (eq status :inherited) + (push sym inherited-symbols) (incf inherited-symbols-length) + (go :continue)) + (push sym present-symbols) (incf present-symbols-length) + (cond ((eq status :internal) + (push sym internal-symbols) (incf internal-symbols-length)) + (t + (push sym external-symbols) (incf external-symbols-length)))) + :continue) + + (setf package-nicknames (sort (copy-list package-nicknames) + #'string<) + package-use-list (sort (copy-list package-use-list) + #'string< :key #'package-name) + package-used-by-list (sort (copy-list package-used-by-list) + #'string< :key #'package-name) + shadowed-symbols (sort (copy-list shadowed-symbols) + #'string<)) + ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. + (setf present-symbols (sort present-symbols #'string<) + internal-symbols (sort internal-symbols #'string<) + external-symbols (sort external-symbols #'string<) + inherited-symbols (sort inherited-symbols #'string<)) + `("" ;; dummy to preserve indentation. + "Name: " (:value ,package-name) (:newline) + + "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) + + ,@(when (documentation package t) + `("Documentation:" (:newline) + ,(documentation package t) (:newline))) + + "Use list: " ,@(common-seperated-spec + package-use-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + "Used by list: " ,@(common-seperated-spec + package-used-by-list + (lambda (package) + `(:value ,package ,(package-name package)))) + (:newline) + + ,(display-link "present" present-symbols present-symbols-length + :title + (format nil "All present symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered present in a package if it's" + (:newline) + "\"accessible in that package directly, rather than" + (:newline) + "being inherited from another package.\"" + (:newline) + "(CLHS glossary entry for `present')" + (:newline))) + + (:newline) + ,(display-link "external" external-symbols external-symbols-length + :title + (format nil "All external symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered external of a package if it's" + (:newline) + "\"part of the `external interface' to the package and" + (:newline) + "[is] inherited by any other package that uses the" + (:newline) + "package.\" (CLHS glossary entry of `external')" + (:newline))) + (:newline) + ,(display-link "internal" internal-symbols internal-symbols-length + :title + (format nil "All internal symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered internal of a package if it's" + (:newline) + "present and not external---that is if the package is" + (:newline) + "the home package of the symbol, or if the symbol has" + (:newline) + "been explicitly imported into the package." + (:newline) + (:newline) + "Notice that inherited symbols will thus not be listed," + (:newline) + "which deliberately deviates from the CLHS glossary" + (:newline) + "entry of `internal' because it's assumed to be more" + (:newline) + "useful this way." + (:newline))) + (:newline) + ,(display-link "inherited" inherited-symbols inherited-symbols-length + :title + (format nil "All inherited symbols of package \"~A\"" + package-name) + :description + '("A symbol is considered inherited in a package if it" + (:newline) + "was made accessible via USE-PACKAGE." + (:newline))) + (:newline) + ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) + :title + (format nil "All shadowed symbols of package \"~A\"" + package-name) + :description nil)))) + + +(defmethod emacs-inspect ((pathname pathname)) + `(,(if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + (:newline) + ,@(label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + ,@ (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname))))) + +(defmethod emacs-inspect ((pathname logical-pathname)) + (append + (label-value-line* + ("Namestring" (namestring pathname)) + ("Physical pathname: " (translate-logical-pathname pathname))) + `("Host: " + (:value ,(pathname-host pathname)) + " (" + (:value ,(logical-pathname-translations + (pathname-host pathname))) + " other translations)" + (:newline)) + (label-value-line* + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname)) + ("Truename" (if (not (wild-pathname-p pathname)) + (probe-file pathname)))))) + +(defmethod emacs-inspect ((n number)) + `("Value: " ,(princ-to-string n))) + +(defun format-iso8601-time (time-value &optional include-timezone-p) + "Formats a universal time TIME-VALUE in ISO 8601 format, with + the time zone included if INCLUDE-TIMEZONE-P is non-NIL" + ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html + ;; Thanks, Nikolai Sandved and Thomas Russ! + (flet ((format-iso8601-timezone (zone) + (if (zerop zone) + "Z" + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + ;; Tricky. Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (format nil "~:[+~;-~]~2,'0D:~2,'0D" + (> zone 0) h (round (* 60 m))))))) + (multiple-value-bind (second minute hour day month year dow dst zone) + (decode-universal-time time-value) + (declare (ignore dow)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + include-timezone-p (format-iso8601-timezone (if dst + (+ zone 1) + zone)))))) + +(defmethod emacs-inspect ((i integer)) + (append + `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" + i i i i (ignore-errors (coerce i 'float))) + (:newline)) + (when (< -1 i char-code-limit) + (label-value-line "Code-char" (code-char i))) + (label-value-line "Integer-length" (integer-length i)) + (ignore-errors + (label-value-line "Universal-time" (format-iso8601-time i t))))) + +(defmethod emacs-inspect ((c complex)) + (label-value-line* + ("Real part" (realpart c)) + ("Imaginary part" (imagpart c)))) + +(defmethod emacs-inspect ((r ratio)) + (label-value-line* + ("Numerator" (numerator r)) + ("Denominator" (denominator r)) + ("As float" (float r)))) + +(defmethod emacs-inspect ((f float)) + (cond + ((float-nan-p f) + ;; try NaN first because the next tests may perform operations + ;; that are undefined for NaNs. + (list "Not a Number.")) + ((not (float-infinity-p f)) + (multiple-value-bind (significand exponent sign) (decode-float f) + (append + `("Scientific: " ,(format nil "~E" f) (:newline) + "Decoded: " + (:value ,sign) " * " + (:value ,significand) " * " + (:value ,(float-radix f)) "^" + (:value ,exponent) (:newline)) + (label-value-line "Digits" (float-digits f)) + (label-value-line "Precision" (float-precision f))))) + ((> f 0) + (list "Positive infinity.")) + ((< f 0) + (list "Negative infinity.")))) + +(defun make-pathname-ispec (pathname position) + `("Pathname: " + (:value ,pathname) + (:newline) " " + ,@(when position + `((:action "[visit file and show current position]" + ,(lambda () + (ed-in-emacs `(,pathname :position ,position :bytep t))) + :refreshp nil) + (:newline))))) + +(defun make-file-stream-ispec (stream) + ;; SBCL's socket stream are file-stream but are not associated to + ;; any pathname. + (let ((pathname (ignore-errors (pathname stream)))) + (when pathname + (make-pathname-ispec pathname (and (open-stream-p stream) + (file-position stream)))))) + +(defmethod emacs-inspect ((stream file-stream)) + (multiple-value-bind (content) + (call-next-method) + (append (make-file-stream-ispec stream) content))) + +(defmethod emacs-inspect ((condition stream-error)) + (multiple-value-bind (content) + (call-next-method) + (let ((stream (stream-error-stream condition))) + (append (when (typep stream 'file-stream) + (make-file-stream-ispec stream)) + content)))) + +(defun common-seperated-spec (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast + (loop + for i in list + collect (funcall callback i) + collect ", "))) + +(defun inspector-princ (list) + "Like princ-to-string, but don't rewrite (function foo) as #'foo. +Do NOT pass circular lists to this function." + (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) + (set-pprint-dispatch '(cons (member function)) nil) + (princ-to-string list))) + +(provide :slynk/fancy-inspector) blob - /dev/null blob + 50ff361da8cfe905ef1ae606ef0a93875091ad65 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-indentation.lisp @@ -0,0 +1,140 @@ +(in-package :slynk) + +(defvar *application-hints-tables* '() + "A list of hash tables mapping symbols to indentation hints (lists +of symbols and numbers as per cl-indent.el). Applications can add hash +tables to the list to change the auto indentation sly sends to +emacs.") + +(defun has-application-indentation-hint-p (symbol) + (let ((default (load-time-value (gensym)))) + (dolist (table *application-hints-tables*) + (let ((indentation (gethash symbol table default))) + (unless (eq default indentation) + (return-from has-application-indentation-hint-p + (values indentation t)))))) + (values nil nil)) + +(defun application-indentation-hint (symbol) + (let ((indentation (has-application-indentation-hint-p symbol))) + (labels ((walk (indentation-spec) + (etypecase indentation-spec + (null nil) + (number indentation-spec) + (symbol (string-downcase indentation-spec)) + (cons (cons (walk (car indentation-spec)) + (walk (cdr indentation-spec))))))) + (walk indentation)))) + +;;; override slynk version of this function +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. + +The form is to be used as the `sly-common-lisp-indent-function' property +in Emacs." + (cond + ((has-application-indentation-hint-p symbol) + (application-indentation-hint symbol)) + ((and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist))))) + (t nil))) + +;;; More complex version. +(defun macro-indentation (arglist) + (labels ((frob (list &optional base) + (if (every (lambda (x) + (member x '(nil "&rest") :test #'equal)) + list) + ;; If there was nothing interesting, don't return anything. + nil + ;; Otherwise substitute leading NIL's with 4 or 1. + (let ((ok t)) + (substitute-if (if base + 4 + 1) + (lambda (x) + (if (and ok (not x)) + t + (setf ok nil))) + list)))) + (walk (list level &optional firstp) + (when (consp list) + (let ((head (car list))) + (if (consp head) + (let ((indent (frob (walk head (+ level 1) t)))) + (cons (list* "&whole" (if (zerop level) + 4 + 1) + indent) (walk (cdr list) level))) + (case head + ;; &BODY is &BODY, this is clear. + (&body + '("&body")) + ;; &KEY is tricksy. If it's at the base level, we want + ;; to indent them normally: + ;; + ;; (foo bar quux + ;; :quux t + ;; :zot nil) + ;; + ;; If it's at a destructuring level, we want indent of 1: + ;; + ;; (with-foo (var arg + ;; :foo t + ;; :quux nil) + ;; ...) + (&key + (if (zerop level) + '("&rest" nil) + '("&rest" 1))) + ;; &REST is tricksy. If it's at the front of + ;; destructuring, we want to indent by 1, otherwise + ;; normally: + ;; + ;; (foo (bar quux + ;; zot) + ;; ...) + ;; + ;; but + ;; + ;; (foo bar quux + ;; zot) + (&rest + (if (and (plusp level) firstp) + '("&rest" 1) + '("&rest" nil))) + ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there + ;; at all. + ((&whole &environment) + (walk (cddr list) level firstp)) + ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker + ;; itself is not counted. + (&optional + (walk (cdr list) level)) + ;; Indent normally, walk the tail -- but + ;; unknown lambda-list keywords terminate the walk. + (otherwise + (unless (member head lambda-list-keywords) + (cons nil (walk (cdr list) level)))))))))) + (frob (walk arglist 0 t) t))) + +#+nil +(progn + (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") + (macro-indentation '(bar quux (&rest slots) &body body)))) + (assert (equal nil + (macro-indentation '(a b c &rest more)))) + (assert (equal '(4 4 4 "&body") + (macro-indentation '(a b c &body more)))) + (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") + (macro-indentation '((name zot &key foo bar) &body body)))) + (assert (equal nil + (macro-indentation '(x y &key z))))) + +(provide :slynk/indentation) blob - /dev/null blob + a84336ce95da187b1ca16d7b46dd164c4a828ba1 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-mrepl.lisp @@ -0,0 +1,753 @@ +;;; slynk-mrepl.lisp +;; +;; Licence: public domain + +(defpackage :slynk-mrepl + (:use :cl :slynk-api) + (:import-from :slynk + #:*globally-redirect-io* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*dedicated-output-stream-buffering*) + (:export #:create-mrepl + #:globally-save-object + #:eval-for-mrepl + #:sync-package-and-default-directory + #:pprint-entry + #:inspect-entry + #:guess-and-set-package + #:copy-to-repl + #:describe-entry + #:send-prompt + #:copy-to-repl-in-emacs)) +(in-package :slynk-mrepl) + + +;;; MREPL models +(defclass mrepl (channel listener) + ((remote-id :initarg :remote-id :accessor mrepl-remote-id) + (mode :initform :eval :accessor mrepl-mode) + (pending-errors :initform nil :accessor mrepl-pending-errors)) + (:documentation "A listener implemented in terms of a channel.") + (:default-initargs + :initial-env (copy-tree ; github#626 + `((cl:*package* . ,cl:*package*) + (cl:*default-pathname-defaults* + . ,cl:*default-pathname-defaults*) + (*) (**) (***) + (/) (//) (///) + (+) (++) (+++) + (*history* . ,(make-array 40 :fill-pointer 0 + :adjustable t)))))) + +(defmethod print-object ((r mrepl) stream) + (print-unreadable-object (r stream :type t) + (format stream "mrepl-~a-~a" (channel-id r) (mrepl-remote-id r)))) + +(defmethod initialize-instance :before ((r mrepl) &key) + (setf (slot-value r 'slynk::in) (make-mrepl-input-stream r))) + + +;;; Helpers +;;; +(defvar *history* nil) + +(defvar *saved-objects* nil) + +(defmethod slynk::drop-unprocessed-events ((r mrepl)) + "Empty REPL of events, then send prompt to Emacs." + ;; FIXME: Dropping events should be moved to the library, and this + ;; :DROP nonsense dropped, hence the deliberate SLYNK::. + (with-slots (mode) r + (let ((old-mode mode)) + (setf mode :drop) + (unwind-protect + (process-requests t) + (setf mode old-mode))))) + +(defun mrepl-get-history-entry (entry-idx) + (let ((len (length *history*))) + (assert (and entry-idx + (integerp entry-idx) + (< -1 entry-idx len)) + nil + "Illegal history entry ~a for ~a-long history" + entry-idx + len) + (aref *history* entry-idx))) + +(defun mrepl-get-object-from-history (entry-idx &optional value-idx) + (let* ((entry (mrepl-get-history-entry entry-idx)) + (len (length entry))) + (assert (or (not value-idx) + (and (integerp value-idx) + (< -1 value-idx len))) + nil + "History entry ~a is only ~a elements long." + entry-idx + len + value-idx) + (if (numberp value-idx) + (nth value-idx entry) + (values-list entry)))) + +(defparameter *backreference-character* #\v + "Character used for #v: backreferences in the REPL. +Set this to some other value if it conflicts with some other reader +macro that you wish to use in the REPL. +Set this to NIL to turn this feature off.") + +(defun backreference-reader (stream subchar arg) + "Reads #rfoo:bar into (MREPL-GET-OBJECT-FROM-HISTORY foo bar)." + (declare (ignore subchar arg)) + (let* ((*readtable* + (let ((table (copy-readtable nil))) + (set-macro-character #\: (lambda (&rest args) nil) nil table) + table)) + (entry-idx + (progn + (when (eq #\: (peek-char nil stream nil nil)) + (error 'reader-error + :stream stream + :format-control "~a found in unexpected place in ~a" + :format-arguments `(#\: backreference-reader))) + (read-preserving-whitespace stream))) + (value-idx (progn + (and (eq #\: (peek-char nil stream nil nil)) + (read-char stream) + (read stream))))) + `(mrepl-get-object-from-history + ,entry-idx ,value-idx))) + +#+nil +(defun backreference-reader-tests () + (let ((expectations + '(("#v:something" error) + ("#vnotanumber:something" (notanumber something)) + ("#vnotanumber" (notanumber nil)) + ("#v2 :something" (2 nil) :something) + ("#v2:99 :something-else" (2 99) :something-else))) + (*readtable* (let ((table (copy-readtable))) + (if *backreference-character* + (set-dispatch-macro-character + #\# + *backreference-character* + #'backreference-reader table)) + table))) + (loop for (input expected-spec following) in expectations + collect + (handler-case + (progn + (with-input-from-string (s input) + (let* ((observed (read s)) + (expected + (progn + (if (eq 'error expected-spec ) + (error "oops, ~a was supposed to have errored, but returned ~a" + input observed)) + `(mrepl-get-object-from-history ,@expected-spec))) + (observed-second (and following + (read s)))) + (unless (equal observed expected) + (error "oops, ~a was supposed to have returned ~a, but returned ~a" + input expected observed)) + (unless (equal observed-second following) + (error "oops, ~a was have read ~a after, but read ~a" + input following observed-second)) + (list observed observed-second)))) + (reader-error (e) + (unless (eq 'error expected-spec) + (error "oops, ~a wasn't supposed to error with ~a" input e))))))) + +(defun make-results (objects) + (loop for value in objects + collect (list (present-for-emacs value #'slynk-pprint) + (1- (length *history*)) + (cond ((symbolp value) + (with-output-to-string (s) + (unless (keywordp value) (princ "'" s)) + (write value :stream s :case :downcase))) + ((numberp value) + (princ-to-string value)))))) + +(defun mrepl-eval (repl string) + (let ((aborted t) + (results) + (error-prompt-sent)) + (setf (mrepl-mode repl) :busy) + (unwind-protect + (let* ((previous-hook *debugger-hook*) + (*debugger-hook* + ;; Here's how this debugger hook handles "debugger + ;; levels". + ;; + ;; (1) This very lambda may be called multiple + ;; times, but *not recursively, for the same + ;; MREPL-EVAL call. That is becasue because SLY's + ;; top-level debugger hook enters a blocking + ;; SLY-DB-LOOP, and letting users invoke all manners + ;; of restarts established in the code they wants us + ;; to evaluate. It's important that we mark the + ;; condition that led to the debugger only once, in + ;; the ERRORRED var. On that occasion, we also send + ;; a prompt to the REPL and increase the debugger + ;; level. If the user selects a restart that + ;; re-runs (but *not* recursively) this very lambda, + ;; we do *not* want to send a prompt again. + ;; + ;; (2) This lambda may also run multiple times, but + ;; recursively, in the very special case of nested + ;; MREPL-EVAL may be nested (if the program calls + ;; PROCESS-REQUESTS explicitly e.g.). We + ;; (hackishly) detect this case by checking by + ;; checking the car of MREPL-PENDING-ERRORS. In + ;; that case, we are sure that calling previous hook + ;; (which is a different copy of this very lambda + ;; but running in a different stack frame) will take + ;; care of the prompt sending and error management + ;; for us, so we just do that. + (lambda (condition hook) + (setq aborted condition) + (cond ((eq condition (car (mrepl-pending-errors repl))) + (funcall previous-hook condition hook)) + (t + (push condition (mrepl-pending-errors repl)) + (unless error-prompt-sent + (setq error-prompt-sent t) + (with-listener-bindings repl + (send-prompt repl condition))) + (unwind-protect + (funcall previous-hook condition hook) + (pop (mrepl-pending-errors repl)))))))) + (setq results (mrepl-eval-1 repl string) + ;; If somehow the form above MREPL-EVAL-1 exited + ;; normally, set ABORTED to nil + aborted nil)) + (unless (eq (mrepl-mode repl) :teardown) + (flush-listener-streams repl) + (saving-listener-bindings repl + (cond (aborted + (send-to-remote-channel (mrepl-remote-id repl) + `(:evaluation-aborted + ,(slynk::without-printing-errors + (:object aborted :stream nil) + (prin1-to-string aborted))))) + (t + (when results + (setq /// // // / / results + *** ** ** * * (car results)) + (vector-push-extend results *history*)) + (send-to-remote-channel + (mrepl-remote-id repl) + `(:write-values ,(make-results results))))) + (send-prompt repl)))))) + +(defun prompt-arguments (repl condition) + "Return (PACKAGE NICKNAME ELEVEL ENTRY-IDX &optional CONDITION)" + `(,(package-name *package*) + ,(package-string-for-prompt *package*) + ,(length (mrepl-pending-errors repl)) + ,(length *history*) + ,@(when condition + (list (write-to-string condition + :escape t + :readably nil))))) + +(defun send-prompt (&optional (repl *channel*) condition) + (send-to-remote-channel (mrepl-remote-id repl) + `(:prompt ,@(prompt-arguments repl condition))) + (setf (mrepl-mode repl) :eval)) + +(defun mrepl-eval-1 (repl string) + "In REPL's environment, READ and EVAL forms in STRING." + (with-sly-interrupts + ;; Use WITH-LISTENER-BINDINGS (not SAVING-LISTENER-BINDINGS) + ;; instead, otherwise, if EVAL pops up an error in STRING's form, + ;; and in the meantime we had some debugging prompts (which make + ;; recursive calls to this function), the variables *, **, *** and + ;; *HISTORY* will get incorrectly clobbered to their pre-debugger + ;; values, whereas we want to serialize this history. + ;; + ;; However, as an exception, we /do/ want /some/ special symbols + ;; to be clobbered if the evaluation of STRING eventually + ;; completes. Currently, those are *PACKAGE* and + ;; *DEFAULT-PATHNAME-DEFAULTS*. + ;; + ;; Another way to see this is: the forms that the user inputs can + ;; only change binding of those special symbols in the listener's + ;; environment. Everything else in there is handled automatically. + ;; + (with-listener-bindings repl + (prog1 + (with-retry-restart (:msg "Retry SLY mREPL evaluation request.") + (with-input-from-string (in string) + (loop with values + for form = + (let ((*readtable* (let ((table (copy-readtable))) + (if *backreference-character* + (set-dispatch-macro-character + #\# + *backreference-character* + #'backreference-reader table)) + table))) + (read in nil in)) + until (eq form in) + do (let ((- form)) + (setq values (multiple-value-list + (eval + (saving-listener-bindings repl + (setq +++ ++ ++ + + form)))))) + finally + (return values)))) + (dolist (special-sym '(*package* *default-pathname-defaults*)) + (setf (cdr (assoc special-sym (slot-value repl 'slynk::env))) + (symbol-value special-sym))))))) + +(defun set-external-mode (repl new-mode) + (with-slots (mode remote-id) repl + (unless (eq mode new-mode) + (send-to-remote-channel remote-id `(:set-read-mode ,new-mode))) + (setf mode new-mode))) + +(defun read-input (repl) + (with-slots (mode remote-id) repl + ;; shouldn't happen with slynk-gray.lisp, they use locks + (assert (not (eq mode :read)) nil "Cannot pipeline READs") + (let ((tid (slynk-backend:thread-id (slynk-backend:current-thread))) + (old-mode mode)) + (unwind-protect + (cond ((and (eq (channel-thread-id repl) tid) + (eq mode :busy)) + (flush-listener-streams repl) + (set-external-mode repl :read) + (unwind-protect + (catch 'mrepl-read (process-requests nil)) + (set-external-mode repl :finished-reading))) + (t + (setf mode :read) + (with-output-to-string (s) + (format s + (or (slynk::read-from-minibuffer-in-emacs + (format nil "Input for thread ~a? " tid)) + (error "READ for thread ~a interrupted" tid))) + (terpri s)))) + (setf mode old-mode))))) + + +;;; Channel methods +;;; +(define-channel-method :inspect-object ((r mrepl) entry-idx value-idx) + (with-listener-bindings r + (send-to-remote-channel + (mrepl-remote-id r) + `(:inspect-object + ,(slynk::inspect-object + (mrepl-get-object-from-history entry-idx value-idx)))))) + +(define-channel-method :process ((c mrepl) string) + (with-slots (mode) c + (case mode + (:eval (mrepl-eval c string)) + (:read (throw 'mrepl-read string)) + (:drop)))) + +(define-channel-method :teardown ((r mrepl)) + ;; FIXME: this should be a `:before' spec and closing the channel in + ;; slynk.lisp's :teardown method should suffice. + ;; + (setf (mrepl-mode r) :teardown) + (call-next-method)) + +(define-channel-method :clear-repl-history ((r mrepl)) + (saving-listener-bindings r + ;; FIXME: duplication... use reinitialize-instance + (setf *history* (make-array 40 :fill-pointer 0 + :adjustable t) + * nil ** nil *** nil + + nil ++ nil +++ nil + / nil // nil /// nil) + (send-to-remote-channel (mrepl-remote-id r) `(:clear-repl-history)) + (send-prompt r))) + + +;;; slyfuns +;;; +(defslyfun create-mrepl (remote-id) + (let* ((mrepl (make-instance + 'mrepl + :remote-id remote-id + :name (format nil "mrepl-remote-~a" remote-id) + :out (make-mrepl-output-stream remote-id)))) + (let ((target (maybe-redirect-global-io *emacs-connection*))) + (saving-listener-bindings mrepl + (format *standard-output* "~&; SLY ~a (~a)~%" + *slynk-wire-protocol-version* + mrepl) + (cond + ((and target + (not (eq mrepl target))) + (format *standard-output* "~&; Global redirection setup elsewhere~%")) + ((not target) + (format *standard-output* "~&; Global redirection not setup~%")))) + (flush-listener-streams mrepl) + (send-prompt mrepl) + (list (channel-id mrepl) (channel-thread-id mrepl))))) + +(defslyfun globally-save-object (slave-slyfun &rest args) + "Apply SLYFUN to ARGS and save the value. + The saved value should be visible to all threads and retrieved via + the COPY-TO-REPL slyfun." + (setq *saved-objects* (multiple-value-list (apply slave-slyfun args))) + t) + +(defun copy-to-repl-in-emacs (values &key + (blurb "Here are some values") + (pop-to-buffer t)) + "Copy any user object to SLY's REPL. Requires + `sly-enable-evaluate-in-emacs' to be true." + (with-connection ((default-connection)) + (apply #'slynk-mrepl:globally-save-object #'cl:values values) + (slynk:eval-in-emacs `(sly-mrepl--copy-globally-saved-to-repl + :before ,blurb :pop-to-buffer ,pop-to-buffer)) + t)) + +(defmacro with-eval-for-repl ((remote-id &optional mrepl-sym + update-mrepl) &body body) + (let ((mrepl-sym (or mrepl-sym + (gensym)))) + `(let ((,mrepl-sym (find-channel ,remote-id))) + (assert ,mrepl-sym) + (assert + (eq (slynk-backend:thread-id + (slynk-backend:current-thread)) + (channel-thread-id ,mrepl-sym)) + nil + "This SLYFUN can only be called from threads belonging to MREPL") + ,(if update-mrepl + `(saving-listener-bindings ,mrepl-sym + ,@body) + `(with-listener-bindings ,mrepl-sym + ,@body))))) + +(defslyfun eval-for-mrepl (remote-id slave-slyfun &rest args) + "A synchronous form for evaluation in the mREPL context. + +Calls SLAVE-SLYFUN with ARGS in the MREPL of REMOTE-ID. Both the +target MREPL's thread and environment are considered. + +SLAVE-SLYFUN is typically destructive to the REPL listener's +environment. + +This function returns a list of two elements. The first is a list +of arguments as sent in the :PROMPT channel method reply. The second +is the values list returned by SLAVE-SLYFUN transformed into a normal +list." + (with-eval-for-repl (remote-id mrepl 'allow-destructive) + (let ((objects (multiple-value-list (apply slave-slyfun args)))) + (list + (prompt-arguments mrepl nil) + objects)))) + +(defslyfun inspect-entry (remote-id entry-idx value-idx) + (with-eval-for-repl (remote-id) + (slynk::inspect-object + (mrepl-get-object-from-history entry-idx value-idx)))) + +(defslyfun describe-entry (remote-id entry-idx value-idx) + (with-eval-for-repl (remote-id) + (slynk::describe-to-string + (mrepl-get-object-from-history entry-idx value-idx)))) + +(defslyfun pprint-entry (remote-id entry-idx value-idx) + (with-eval-for-repl (remote-id) + (slynk::slynk-pprint + (list (mrepl-get-object-from-history entry-idx value-idx))))) + + +;;; "Slave" slyfuns. +;;; +;;; These are slyfuns intented to be called as the SLAVE-SLYFUN +;;; argument of EVAL-FOR-MREPL. +;;; + +(defslyfun guess-and-set-package (package-name) + (let ((package (slynk::guess-package package-name))) + (if package + (setq *package* package) + (error "Can't find a package for designator ~a" package-name)) + t)) + +(defslyfun copy-to-repl (&optional entry-idx value-idx) + "Recall objects in *HISTORY* or *SAVED-OBJECTS* as the last entry." + (let ((objects + (cond ((and entry-idx value-idx) + (list (mrepl-get-object-from-history entry-idx value-idx))) + (entry-idx + (mrepl-get-history-entry entry-idx)) + (value-idx + (error "Doesn't make sense")) + (t + *saved-objects*)))) + (setq /// // // / / objects + *** ** ** * * (car objects)) + (vector-push-extend objects *history*) + (values-list (make-results objects)))) + +(defslyfun sync-package-and-default-directory (&key package-name directory) + (when directory + (slynk:set-default-directory directory)) + (when package-name + (guess-and-set-package package-name)) + (values (package-name *package*) (slynk-backend:default-directory))) + + +;;;; Dedicated stream +;;;; +(defvar *use-dedicated-output-stream* :started-from-emacs + "When T, dedicate a second stream for sending output to Emacs.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *dedicated-output-stream-buffering* + (if (eq slynk:*communication-style* :spawn) :line nil) + "The buffering scheme that should be used for the output stream. +Be advised that some Lisp backends don't support this. +Valid values are nil, t, :line.") + +(defun use-dedicated-output-stream-p () + (case *use-dedicated-output-stream* + (:started-from-emacs slynk-api:*m-x-sly-from-emacs*) + (t *use-dedicated-output-stream*))) + +(defun make-mrepl-output-stream (remote-id) + (or (and (use-dedicated-output-stream-p) + (open-dedicated-output-stream remote-id)) + (slynk-backend:make-output-stream + (make-thread-bindings-aware-lambda + (lambda (string) + (send-to-remote-channel remote-id `(:write-string ,string))))))) + +(defun make-mrepl-input-stream (repl) + (slynk-backend:make-input-stream + (lambda () (read-input repl)))) + +(defun open-dedicated-output-stream (remote-id) + "Establish a dedicated output connection to Emacs. + +Emacs's channel at REMOTE-ID is notified of a socket listening at an +ephemeral port. Upon connection, the listening socket is closed, and +the resulting connecion socket is used as optimized way for Lisp to +deliver output to Emacs." + (let ((socket (slynk-backend:create-socket slynk::*loopback-interface* + *dedicated-output-stream-port*)) + (ef (or (some #'slynk::find-external-format '("utf-8-unix" "utf-8")) + (error "no suitable coding system for dedicated stream")))) + (unwind-protect + (let ((port (slynk-backend:local-port socket))) + (send-to-remote-channel remote-id + `(:open-dedicated-output-stream ,port nil)) + (let ((dedicated (slynk-backend:accept-connection + socket + :external-format ef + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (slynk:authenticate-client dedicated) + (slynk-backend:close-socket socket) + (setf socket nil) + (let ((result + ;; See github issue #21: Only sbcl and cmucl apparently + ;; respect :LINE as a buffering type, hence this reader + ;; conditional. This could/should be a definterface, but + ;; looks harmless enough... + ;; + #+(or sbcl cmucl) + dedicated + ;; ...on other implementations we make a relaying gray + ;; stream that is guaranteed to use line buffering for + ;; WRITE-SEQUENCE. That stream writes to the dedicated + ;; socket whenever it sees fit. + ;; + #-(or sbcl cmucl) + (slynk-backend:make-output-stream + (lambda (string) + (write-sequence string dedicated) + (force-output dedicated))))) + (prog1 result + (format result + "~&; Dedicated output stream setup (port ~a)~%" + port) + (force-output result))))) + (when socket + (slynk-backend:close-socket socket))))) + + +;;;; Globally redirect IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. If any LISTENER objects +;;; exist in the CONNECTION structure, they will contain the +;;; appropriate streams, so all we have to do is make the right +;;; bindings. +;;; +;;; When the first ever MREPL is created we redirect the streams into +;;; it, and they keep going into that MREPL even if more are +;;; established, in the current connection or even other +;;; connections. If the MREPL is closed (interactively or by closing +;;; the connection), we choose some other MREPL (in some other default +;;; connection possibly), or, or if there are no MREPL's left, we +;;; revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. +(defvar *globally-redirect-io* :started-from-emacs + "If non-nil, attempt to globally redirect standard streams to Emacs. +If the value is :STARTED-FROM-EMACS, do it only if the Slynk server +was started from SLYNK:START-SERVER, which is called from Emacs by M-x +sly.") + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defvar *target-listener-for-redirection* nil + "The listener to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (let ((stream (make-synonym-stream current-stream-var))) + (set stream-var stream) + (slynk::set-default-initial-binding stream-var `(quote ,stream))))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SLYNK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :slynk))) + +(defun init-global-stream-redirection () + (cond (*saved-global-streams* + (warn "Streams already redirected.")) + (t + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*))))) + +(defun globally-redirect-to-listener (listener) + "Set the standard I/O streams to redirect to LISTENER. +Assigns *CURRENT-* for all standard streams." + (saving-listener-bindings listener + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + *standard-output*)) + + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + *terminal-io*)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-* to *REAL-* for all standard streams." + ;; Log to SLYNK:*LOG-OUTPUT* since the standard streams whose + ;; redirection are about to be reverted might be in an unconsistent + ;; state after, for instance, restarting an image. + ;; + (format slynk:*log-output* "~&; About to revert global IO direction~%") + (when *target-listener-for-redirection* + (flush-listener-streams *target-listener-for-redirection*)) + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +(defun globally-redirect-io-p () + (case *globally-redirect-io* + (:started-from-emacs slynk-api:*m-x-sly-from-emacs*) + (t *globally-redirect-io*))) + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting output to CONNECTION's listener. + +Return the current redirection target, or nil" + (let ((l (default-listener connection))) + (when (and (globally-redirect-io-p) + (null *target-listener-for-redirection*) + l) + (unless *saved-global-streams* + (init-global-stream-redirection)) + (setq *target-listener-for-redirection* l) + (globally-redirect-to-listener l) + (with-listener-bindings l + (format *standard-output* "~&; Redirecting all output to this MREPL~%") + (flush-listener-streams l))) + *target-listener-for-redirection*)) + +(defmethod close-channel :before ((r mrepl) &key force) + (with-slots (mode remote-id) r + (unless (or force (eq mode :teardown)) + (send-to-remote-channel remote-id `(:server-side-repl-close))) + ;; If this channel was the redirection target. + (close-listener r) + (when (eq r *target-listener-for-redirection*) + (setq *target-listener-for-redirection* nil) + (maybe-redirect-global-io (default-connection)) + (unless *target-listener-for-redirection* + (revert-global-io-redirection) + (format slynk:*log-output* "~&; Reverted global IO direction~%"))))) + +(provide :slynk/mrepl) blob - /dev/null blob + 112643effe4fb1a3d65315e9cf4214cb538be4c6 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-package-fu.lisp @@ -0,0 +1,76 @@ + +(in-package :slynk) + +(defslyfun package= (string1 string2) + (let* ((pkg1 (guess-package string1)) + (pkg2 (guess-package string2))) + (and pkg1 pkg2 (eq pkg1 pkg2)))) + +(defslyfun export-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (export `(,(from-string symbol-str)) package))))) + +(defslyfun import-symbol-for-emacs (symbol-str + destination-package-str + origin-package-str) + (let ((destination (guess-package destination-package-str)) + (origin (guess-package origin-package-str))) + (when (and destination origin) + (let* ((*buffer-package* origin) + (symbol (from-string symbol-str))) + (when symbol + (import symbol destination)))))) + +(defslyfun unexport-symbol-for-emacs (symbol-str package-str) + (let ((package (guess-package package-str))) + (when package + (let ((*buffer-package* package)) + (unexport `(,(from-string symbol-str)) package))))) + +#+sbcl +(defun list-structure-symbols (name) + (let ((dd (sb-kernel:find-defstruct-description name ))) + (list* name + (sb-kernel:dd-default-constructor dd) + (sb-kernel:dd-predicate-name dd) + (sb-kernel::dd-copier-name dd) + (mapcar #'sb-kernel:dsd-accessor-name + (sb-kernel:dd-slots dd))))) + +#+ccl +(defun list-structure-symbols (name) + (let ((definition (gethash name ccl::%defstructs%))) + (list* name + (ccl::sd-constructor definition) + (ccl::sd-refnames definition)))) + +(defun list-class-symbols (name) + (let* ((class (find-class name)) + (slots (slynk-mop:class-direct-slots class))) + (labels ((extract-symbol (name) + (if (and (consp name) (eql (car name) 'setf)) + (cadr name) + name)) + (slot-accessors (slot) + (nintersection (copy-list (slynk-mop:slot-definition-readers slot)) + (copy-list (slynk-mop:slot-definition-readers slot)) + :key #'extract-symbol))) + (list* (class-name class) + (mapcan #'slot-accessors slots))))) + +(defslyfun export-structure (name package) + (let ((*package* (guess-package package))) + (when *package* + (let* ((name (from-string name)) + (symbols (cond #+(or sbcl ccl) + ((or (not (find-class name nil)) + (subtypep name 'structure-object)) + (list-structure-symbols name)) + (t + (list-class-symbols name))))) + (export symbols) + symbols)))) + +(provide :slynk/package-fu) blob - /dev/null blob + 9b31fb6813154f9471b619456198034e3f1090bd (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-profiler.lisp @@ -0,0 +1,189 @@ +(defpackage :slynk-profiler + (:use :cl) + (:import-from :slynk :defslyfun :from-string :to-string) + (:export #:toggle-timing + #:untime-spec + #:clear-timing-tree + #:untime-all + #:timed-spec-p + #:time-spec)) + +(in-package :slynk-profiler) + +(defvar *timing-lock* (slynk-backend:make-lock :name "slynk-timings lock")) + +(defvar *current-timing* nil) + +(defvar *timed-spec-lists* (make-array 10 + :fill-pointer 0 + :adjustable t)) + +(defun started-timing ()) + +(defmethod timed-specs () + (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*)))) + +(defmethod (setf timed-specs) (value) + (setf (aref *timed-spec-lists* (1- (fill-pointer *timed-spec-lists*))) value)) + +(defclass timing () + ((parent :reader parent-of :initform *current-timing* ) + (origin :initarg :origin :reader origin-of + :initform (error "must provide an ORIGIN for this TIMING")) + (start :reader start-of :initform (get-internal-real-time)) + (end :accessor end-of :initform nil))) + +(defclass timed-spec () + ((spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (stats :accessor stats-of) + (total :accessor total-of) + (subtimings :accessor subtimings-of) + (owntimings :accessor owntimings-of))) + +(defun get-singleton-create (spec) + (let ((existing (find spec (timed-specs) :test #'equal :key #'spec-of))) + (if existing + (reinitialize-instance existing) + (let ((new (make-instance 'timed-spec :spec spec))) + (push new (timed-specs)) + new)))) + +(defmethod shared-initialize :after ((ts timed-spec) slot-names &rest initargs) + (declare (ignore slot-names)) + (setf (stats-of ts) (make-hash-table) + (total-of ts) 0 + (subtimings-of ts) nil + (owntimings-of ts) nil) + (loop for otherts in (remove ts (timed-specs)) + do (setf (gethash ts (stats-of otherts)) 0) + (setf (gethash otherts (stats-of ts)) 0))) + +(defmethod initialize-instance :after ((tm timing) &rest initargs) + (declare (ignore initargs)) + (push tm (owntimings-of (origin-of tm))) + (let ((parent (parent-of tm))) + (when parent + (push tm (subtimings-of (origin-of parent)))))) + +(defmethod (setf end-of) :after (value (tm timing)) + (let* ((parent (parent-of tm)) + (parent-origin (and parent (origin-of parent))) + (origin (origin-of tm)) + (tm1 (pop (owntimings-of origin))) + (tm2 (and parent + (pop (subtimings-of parent-origin)))) + (delta (- value (start-of tm)))) + (assert (eq tm tm1) nil "Hmm something's gone wrong in the owns") + (assert (or (null tm2) + (eq tm tm2)) nil "Something's gone wrong in the subs") + (when (null (owntimings-of origin)) + (incf (total-of origin) delta)) + (when (and parent-origin + (null (subtimings-of parent-origin))) + (incf (gethash origin (stats-of parent-origin)) + delta)))) + +(defmethod duration ((tm timing)) + (/ (- (or (end-of tm) + (get-internal-real-time)) + (start-of tm)) + internal-time-units-per-second)) + +(defmethod print-object ((tm timing) stream) + (print-unreadable-object (tm stream :type t :identity t) + (format stream "~a: ~f~a" + (spec-of (origin-of tm)) + (duration tm) + (if (not (end-of tm)) "(unfinished)" "")))) + +(defmethod print-object ((e timed-spec) stream) + (print-unreadable-object (e stream :type t) + (format stream "~a ~fs" (spec-of e) + (/ (total-of e) + internal-time-units-per-second)))) + +(defslyfun time-spec (spec) + (when (timed-spec-p spec) + (warn "~a is apparently already timed! Untiming and retiming." spec) + (untime-spec spec)) + (let ((timed-spec (get-singleton-create spec))) + (flet ((before-hook (args) + (declare (ignore args)) + (setf *current-timing* + (make-instance 'timing :origin timed-spec))) + (after-hook (retlist) + (declare (ignore retlist)) + (let* ((timing *current-timing*)) + (when timing + (setf (end-of timing) (get-internal-real-time)) + (setf *current-timing* (parent-of timing)))))) + (slynk-backend:wrap spec 'timings + :before #'before-hook + :after #'after-hook) + (format nil "~a is now timed for timing dialog" spec)))) + +(defslyfun untime-spec (spec) + (slynk-backend:unwrap spec 'timings) + (let ((moribund (find spec (timed-specs) :test #'equal :key #'spec-of))) + (setf (timed-specs) (remove moribund (timed-specs))) + (loop for otherts in (timed-specs) + do (remhash moribund (stats-of otherts)))) + (format nil "~a is now untimed for timing dialog" spec)) + +(defslyfun toggle-timing (spec) + + (if (timed-spec-p spec) + (untime-spec spec) + (time-spec spec))) + +(defslyfun timed-spec-p (spec) + (find spec (timed-specs) :test #'equal :key #'spec-of)) + +(defslyfun untime-all () + (mapcar #'untime-spec (timed-specs))) + + +;;;; Reporting to emacs +;;; +(defun describe-timing-for-emacs (timed-spec) + (declare (ignore timed-spec)) + `not-implemented) + +(defslyfun report-latest-timings () + (loop for spec in (timed-specs) + append (loop for partial being the hash-values of (stats-of spec) + for path being the hash-keys of (stats-of spec) + collect (list (slynk-api:slynk-pprint-to-line spec) partial + (slynk-api:slynk-pprint-to-line path))))) + +(defun print-tree () + (loop for ts in (timed-specs) + for total = (total-of ts) + do (format t "~%~a~%~%" ts) + (when (plusp total) + (loop for partial being the hash-values of (stats-of ts) + for path being the hash-keys of (stats-of ts) + when (plusp partial) + sum partial into total-partials + and + do (format t " ~8fs ~4f% ~a ~%" + (/ partial + internal-time-units-per-second) + (* 100 (/ partial + total)) + (spec-of path)) + finally + (format t " ~8fs ~4f% ~a ~%" + (/ (- total total-partials) + internal-time-units-per-second) + (* 100 (/ (- total total-partials) + total)) + 'other))))) + +(defslyfun clear-timing-tree () + (setq *current-timing* nil) + (loop for ts in (timed-specs) + do (reinitialize-instance ts))) + +(provide :slynk/profiler) blob - /dev/null blob + 682de3f9d761e404380a603c99ee1ee39ecd6b20 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-retro.lisp @@ -0,0 +1,43 @@ +(defpackage :slynk-retro + (:use :cl :slynk :slynk-api)) + +(in-package :slynk-retro) + +(defun ensure-slynk-package-nicknames (&rest ignored) + "Nickname all SLYNK-* package to SWANK-*" + (declare (ignore ignored)) + (loop for package in (list-all-packages) + for package-name = (package-name package) + when (search "SLYNK" package-name :test #'char-equal) + do (rename-package package + package-name + (remove-duplicates + (cons + (format nil "SWANK~a" + (subseq package-name 5)) + (package-nicknames package)) + :test #'string-equal)))) + +(defun load-swankrcs-maybe () + (find-if (lambda (homedir-file) + (load (merge-pathnames (user-homedir-pathname) + homedir-file) + :if-does-not-exist nil)) + (list (make-pathname :name ".swank" :type "lisp") + (make-pathname :name ".swankrc")))) + +(setq slynk-rpc:*translating-swank-to-slynk* nil) +(push #'ensure-slynk-package-nicknames + slynk-api:*slynk-require-hook*) + +(ensure-slynk-package-nicknames) +;;; Take this chance to load ~/.swank.lisp and ~/.swankrc if no +;;; ~/.slynk.lisp or ~/.slynkrc have already been loaded. +;;; +(unless slynk-api:*loaded-user-init-file* + (setq slynk-api:*loaded-user-init-file* + (load-swankrcs-maybe))) + +(provide :slynk/retro) + + blob - /dev/null blob + 9cc4615e8037f51e7aace7590fe7187af411b9f5 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-stickers.lisp @@ -0,0 +1,398 @@ +(defpackage :slynk-stickers + (:use :cl :slynk-api) + (:import-from :slynk-backend :slynk-compile-string) + (:import-from :slynk :defslyfun :compile-string-for-emacs) + (:export #:record + #:compile-for-stickers + #:kill-stickers + #:inspect-sticker + #:inspect-sticker-recording + #:fetch + #:forget + #:total-recordings + #:find-recording-or-lose + #:search-for-recording + #:toggle-break-on-stickers + #:*break-on-stickers*)) +(in-package :slynk-stickers) + +(defvar *next-recording-id* 0) + +(defclass recording () + ((id :initform (incf *next-recording-id*) :accessor id-of) + (ctime :initform (common-lisp:get-universal-time) :accessor ctime-of) + (sticker :initform (error "required") :initarg :sticker :accessor sticker-of) + (values :initform (error "required") :initarg :values :accessor values-of) + (condition :initarg :condition :accessor condition-of))) + +(defmethod initialize-instance :after ((x recording) &key sticker) + (push x (recordings-of sticker)) + (vector-push-extend x *recordings*)) + +(defun recording-description-string (recording + &optional stream print-first-value) + (let ((values (values-of recording)) + (condition (condition-of recording))) + (cond (condition + (format stream "exited non-locally with: ~a" + (present-for-emacs condition))) + ((eq values 'exited-non-locally) + (format stream "exited non-locally")) + ((listp values) + (if (and print-first-value + values) + (format stream "~a" (present-for-emacs (car values))) + (format stream "~a values" (length values)))) + (t + (format stream "corrupt recording"))))) + +(defmethod print-object ((r recording) s) + (print-unreadable-object (r s :type t) + (recording-description-string r s))) + +(defclass sticker () + ((id :initform (error "required") :initarg :id :accessor id-of) + (hit-count :initform 0 :accessor hit-count-of) + (recordings :initform nil :accessor recordings-of) + (ignore-spec :initform nil :accessor ignore-spec-of))) + +(defmethod print-object ((sticker sticker) s) + (print-unreadable-object (sticker s :type t) + (format s "id=~a hit-count=~a" (id-of sticker) (hit-count-of sticker)))) + +(defun exited-non-locally-p (recording) + (when (or (condition-of recording) + (eq (values-of recording) 'exited-non-locally)) + t)) + + +;; FIXME: This won't work for multiple connected SLY clients. A +;; channel, or some connection specific structure, is needed for that. +;; +(defvar *stickers* (make-hash-table)) +(defvar *recordings* (make-array 0 :fill-pointer 0 :adjustable t)) +(defvar *visitor* nil) + +(defslyfun compile-for-stickers (new-stickers + dead-stickers + instrumented-string + original-string + buffer + position + filename + policy) + "Considering NEW-STICKERS, compile INSTRUMENTED-STRING. +INSTRUMENTED-STRING is exerpted from BUFFER at POSITION. BUFFER may be +associated with FILENAME. DEAD-STICKERS if any, are killed. If +compilation succeeds, return a list (NOTES T). + +If ORIGINAL-STRING, if non-nil, is compiled as a fallback if the +previous compilation. In this case a list (NOTES NIL) is returned or +an error is signalled. + +If ORIGINAL-STRING is not supplied and compilation of +INSTRUMENTED-STRING fails, return NIL. + +New stickers for NEW-STICKERS are registered in *STICKERS* and +stickers in DEAD-STICKERS are killed. NEW-STICKERS are not necessarily +\"new\" in the sense that the ids are not assigned by Slynk, but +their ignore-spec is reset nonetheless." + ;; Dead stickers are unconditionally removed from *stickers* + ;; + (kill-stickers dead-stickers) + (let ((probe + (handler-case + (compile-string-for-emacs instrumented-string + buffer + position + filename + policy) + (error () nil)))) + (cond (;; a non-nil and successful compilation result + (and probe + (third probe)) + ;; new objects for NEW-STICKERS are created + (loop for id in new-stickers + do (setf (gethash id *stickers*) + (make-instance 'sticker :id id))) + (list probe t)) + (original-string + (list (compile-string-for-emacs + original-string buffer position filename policy) + nil))))) + +(defslyfun kill-stickers (ids) + (loop for id in ids + do (remhash id *stickers*))) + +(define-condition sticker-related-condition (condition) + ((sticker :initarg :sticker :initform (error "~S is required" 'sticker) + :accessor sticker-of) + (debugger-extra-options :initarg :debugger-extra-options + :accessor debugger-extra-options-of))) + +(define-condition just-before-sticker (sticker-related-condition) + () + (:report (lambda (c stream) + (with-slots (sticker) c + (print-unreadable-object (c stream) + (format stream "JUST BEFORE ~a" sticker)))))) + +(define-condition right-after-sticker (sticker-related-condition) + ((recording :initarg :recording :accessor recording-of)) + (:report (lambda (c stream) + (with-slots (sticker recording) c + (print-unreadable-object (c stream) + (format stream "RIGHT-AFTER ~a (recorded ~a)" + sticker + recording)))))) + +(defparameter *break-on-stickers* nil + "If non-nil, invoke to debugger when evaluating stickered forms. +If a list containing :BEFORE, break before evaluating. If a list +containing :AFTER, break after evaluating. If t, break before and +after.") + +(defslyfun toggle-break-on-stickers () + "Toggle the value of *BREAK-ON-STICKERS*" + (setq *break-on-stickers* (not *break-on-stickers*))) + +(defun invoke-debugger-for-sticker (sticker condition) + (restart-case + (let ((*debugger-extra-options* + (append (debugger-extra-options-of condition) + *debugger-extra-options*))) + (invoke-debugger condition)) + (continue () :report "OK, continue") + (ignore-this-sticker () + :report "Stop bothering me about this sticker" + :test (lambda (c) + (cond ((null c) + ;; test functions will often be called without + ;; conditions. + t) + ((typep c 'sticker-related-condition) + (and (eq (sticker-of c) sticker) + *break-on-stickers*)) + (t + nil))) + (setf (ignore-spec-of sticker) + (list :before :after))))) + +(defun break-on-sticker-p (sticker when) + (and (or (eq t *break-on-stickers*) + (and (listp *break-on-stickers*) + (member when *break-on-stickers*))) + (not (member when (ignore-spec-of sticker))))) + +(defun call-with-sticker-recording (id fn) + (let* ((sticker (gethash id *stickers*)) + (mark (gensym)) + (retval mark) + (last-condition) + (recording)) + (handler-bind ((condition (lambda (condition) + (setq last-condition condition)))) + ;; Maybe break before + ;; + (when sticker + (incf (hit-count-of sticker)) + (when (break-on-sticker-p sticker :before) + (invoke-debugger-for-sticker + sticker (make-condition 'just-before-sticker + :sticker sticker + :debugger-extra-options + `((:slynk-before-sticker ,id)))))) + ;; Run actual code under the sticker + ;; + (unwind-protect + (values-list (setq retval (multiple-value-list (funcall fn)))) + (when sticker + ;; Always make a recording... + ;; + (setq recording + (make-instance 'recording + :sticker sticker + :values (if (eq mark retval) + 'exited-non-locally + retval) + :condition (and (eq mark retval) + last-condition))) + ;; ...and then maybe break after. + (when (break-on-sticker-p sticker :after) + (invoke-debugger-for-sticker + sticker + (make-condition 'right-after-sticker + :sticker sticker + :recording recording + :debugger-extra-options + `((:slynk-after-sticker + ,(describe-sticker-for-emacs + sticker recording))))))))))) + +(defmacro record (id &rest body) + `(call-with-sticker-recording ,id (lambda () ,@body))) + +(define-setf-expander record (x &environment env) + (declare (ignore x env)) + (error "Sorry, not allowing ~S for ~S" 'setf 'record)) + +(defun search-for-recording-1 (from &key + ignore-p + increment) + "Return two values: a RECORDING and its position in *RECORDINGS*. +Start searching from position FROM, an index in *RECORDINGS* which is +successibely increased by INCREMENT before using that to index +*RECORDINGS*." + (loop for starting-position in `(,from ,(if (plusp increment) + -1 + (length *recordings*))) + ;; this funky scheme has something to do with rollover + ;; semantics probably + ;; + for inc in `(,increment ,(if (plusp increment) 1 -1)) + for (rec idx) = (loop for cand-idx = (incf starting-position + inc) + while (< -1 cand-idx (length *recordings*)) + for recording = (aref *recordings* cand-idx) + for sid = (id-of (sticker-of recording)) + unless (funcall ignore-p sid) + return (list recording cand-idx)) + when rec + return (values rec idx))) + +(defun describe-recording-for-emacs (recording) + "Describe RECORDING as (ID CTIME VALUE-DESCRIPTIONS EXITED-NON-LOCALLY-P). +ID is a number. CTIME is the creation time, given by +CL:GET-UNIVERSAL-TIME VALUE-DESCRIPTIONS is a list of +strings. EXITED-NON-LOCALLY-P is an integer." + (list + (id-of recording) + (ctime-of recording) + (and (listp (values-of recording)) + (loop for value in (values-of recording) + collect (slynk-api:present-for-emacs value))) + (exited-non-locally-p recording))) + +(defun describe-sticker-for-emacs (sticker &optional recording) + "Describe STICKER and either its latest recording or RECORDING. +Returns a list (ID NRECORDINGS . RECORDING-DESCRIPTION). +RECORDING-DESCRIPTION is as given by DESCRIBE-RECORDING-FOR-EMACS." + (let* ((recordings (recordings-of sticker)) + (recording (or recording + (first recordings)))) + (list* (id-of sticker) + (length recordings) + (and recording + (describe-recording-for-emacs recording))))) + +(defslyfun total-recordings () + "Tell how many recordings in *RECORDINGS*" (length *recordings*)) + +(defslyfun search-for-recording (key ignored-ids ignore-zombies-p dead-stickers index + &optional command) + "Visit the next recording for the visitor KEY. +IGNORED-IDS is a list of sticker IDs to ignore. IGNORE-ZOMBIES-P is +non-nil if recordings for dead stickers should also be ignored. + +Kill any stickers in DEAD-STICKERS. + +INDEX is an integer designating a recording to move the playhead +to. If COMMAND is nil, INDEX is taken relative to the current +playhead and the search jumps over recordings of stickers in +IGNORE-SPEC. If it is a number, search for the INDEXth recording +of sticker with that ID. Otherwise, jump directly to the INDEXth +recording. + +If a recording can be found return a list (LAST-RECORDING-ID +ABSOLUTE-INDEX . STICKER-DESCRIPTION). ABSOLUTE-INDEX is the position +of recording in the global *RECORDINGS* array. STICKER-DESCRIPTION is +as given by DESCRIBE-STICKER-FOR-EMACS. + +Otherwise returns a list (NIL ERROR-DESCRIPTION)" + (kill-stickers dead-stickers) + (unless (and *visitor* + (eq key (car *visitor*))) + (setf *visitor* (cons key -1))) + (multiple-value-bind (recording absolute-index) + (cond + ((zerop (length *recordings*)) + nil) + ((and command + (not (numberp command))) + (let ((absolute-index (mod index + (length *recordings*)))) + (values (aref *recordings* absolute-index) + absolute-index))) + (t + (search-for-recording-1 + (cdr *visitor*) + :increment index + :ignore-p + (if (numberp command) + (lambda (sid) + (not (= sid command))) + (lambda (sid) + (or (member sid ignored-ids) + (and + ignore-zombies-p + (not (gethash sid *stickers*))))))))) + (cond (recording + (setf (cdr *visitor*) absolute-index) + (list* (length *recordings*) + absolute-index + (describe-sticker-for-emacs (sticker-of recording) recording))) + (t + (list nil "No recording matches that criteria"))))) + +(defslyfun fetch (dead-stickers) + "Describe each known sticker to Emacs. +As always, take the opportunity to kill DEAD-STICKERS" + (kill-stickers dead-stickers) + (loop for sticker being the hash-values of *stickers* + collect (describe-sticker-for-emacs sticker))) + +(defslyfun forget (dead-stickers &optional howmany) + "Forget HOWMANY sticker recordings. +Return number of remaining recordings" + (kill-stickers dead-stickers) + (maphash (lambda (id sticker) + (declare (ignore id)) + (setf (recordings-of sticker) nil)) + *stickers*) + (cond ((null howmany) + (setf *recordings* (make-array 0 :fill-pointer 0 :adjustable t))) + (t + (check-type howmany number) + (let ((remaining (- (length *recordings*) + howmany))) + (assert (not (minusp remaining))) + (setf *recordings* + (make-array remaining + :adjustable t + :fill-pointer t + :initial-contents (subseq *recordings* + howmany)))))) + (length *recordings*)) + +(defslyfun find-recording-or-lose (recording-id vindex) + (let ((recording (find recording-id *recordings* :key #'id-of))) + (if vindex + (elt (values-of recording) vindex) + (values-list (values-of recording))))) + +(defun find-sticker-or-lose (id) + (let ((probe (gethash id *stickers* :unknown))) + (if (eq probe :unknown) + (error "Cannot find sticker ~a" id) + probe))) + +(defslyfun inspect-sticker (sticker-id) + (let ((sticker (find-sticker-or-lose sticker-id))) + (slynk::inspect-object sticker))) + +(defslyfun inspect-sticker-recording (recording-id vindex) + (let ((recording (find-recording-or-lose recording-id vindex))) + (slynk::inspect-object recording))) + +(provide 'slynk/stickers) blob - /dev/null blob + 18c8f7ce17bcda6de1c0ee7af871405e5c319bc7 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/slynk-trace-dialog.lisp @@ -0,0 +1,306 @@ +(defpackage :slynk-trace-dialog + (:use :cl :slynk-api) + (:export #:clear-trace-tree + #:dialog-toggle-trace + #:dialog-trace + #:dialog-traced-p + #:dialog-untrace + #:dialog-untrace-all + #:inspect-trace-part + #:report-partial-tree + #:report-specs + #:report-total + #:report-specs + #:trace-format + #:still-inside + #:exited-non-locally + #:*record-backtrace* + #:*traces-per-report* + #:*dialog-trace-follows-trace* + #:instrument + + #:pprint-trace-part + #:describe-trace-part + #:trace-part-or-lose + #:inspect-trace + #:trace-or-lose + #:trace-arguments-or-lose + #:trace-location)) + +(in-package :slynk-trace-dialog) + +(defparameter *record-backtrace* nil + "Record a backtrace of the last 20 calls for each trace. + +Beware that this may have a drastic performance impact on your +program.") + +(defparameter *traces-per-report* 150 + "Number of traces to report to emacs in each batch.") + +(defparameter *dialog-trace-follows-trace* nil) + +(defvar *traced-specs* '()) + +(defparameter *visitor-idx* 0) + +(defparameter *visitor-key* nil) + +(defvar *unfinished-traces* '()) + + +;;;; `trace-entry' model +;;;; +(defvar *traces* (make-array 1000 :fill-pointer 0 + :adjustable t)) + +(defvar *trace-lock* (slynk-backend:make-lock :name "slynk-trace-dialog lock")) + +(defvar *current-trace-by-thread* (make-hash-table)) + +(defclass trace-entry () + ((id :reader id-of) + (children :accessor children-of :initform nil) + (backtrace :accessor backtrace-of :initform (when *record-backtrace* + (useful-backtrace))) + + (spec :initarg :spec :accessor spec-of + :initform (error "must provide a spec")) + (function :initarg :function :accessor function-of) + (args :initarg :args :reader args-of + :initform (error "must provide args")) + (printed-args) + (parent :initarg :parent :reader parent-of + :initform (error "must provide a parent, even if nil")) + (retlist :initarg :retlist :accessor retlist-of + :initform 'still-inside) + (printed-retlist :initform ":STILL-INSIDE"))) + +(defmethod initialize-instance :after ((entry trace-entry) &key) + (with-slots (parent id printed-args args) entry + (if parent + (nconc (children-of parent) (list entry))) + (setf printed-args + (mapcar (lambda (arg) + (present-for-emacs arg #'slynk-pprint-to-line)) + args)) + (slynk-backend:call-with-lock-held + *trace-lock* + #'(lambda () + (setf (slot-value entry 'id) (fill-pointer *traces*)) + (vector-push-extend entry *traces*))))) + +(defmethod print-object ((entry trace-entry) stream) + (print-unreadable-object (entry stream) + (format stream "~a=~a" (id-of entry) (spec-of entry)))) + +(defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) + +(defun trace-arguments (trace-id) + (values-list (args-of (trace-or-lose trace-id)))) + +(defun useful-backtrace () + (slynk-backend:call-with-debugging-environment + #'(lambda () + (loop for i from 0 + for frame in (slynk-backend:compute-backtrace 0 20) + collect (list i (slynk::frame-to-string frame)))))) + +(defun current-trace () + (gethash (slynk-backend:current-thread) *current-trace-by-thread*)) + +(defun (setf current-trace) (trace) + (setf (gethash (slynk-backend:current-thread) *current-trace-by-thread*) + trace)) + + +;;;; Helpers +;;;; +(defun describe-trace-for-emacs (trace) + (with-slots (id args parent spec printed-args retlist printed-retlist) trace + `(,id + ,(and parent (id-of parent)) + ,(cons (string-downcase (present-for-emacs spec)) spec) + ,(loop for arg in args + for printed-arg in printed-args + for i from 0 + collect (list i printed-arg)) + ,(loop for retval in (slynk::ensure-list retlist) + for printed-retval in (slynk::ensure-list printed-retlist) + for i from 0 + collect (list i printed-retval))))) + + +;;;; slyfuns +;;;; +(defslyfun trace-format (format-spec &rest format-args) + "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." + (let* ((line (apply #'format nil format-spec format-args))) + (make-instance 'trace-entry :spec line + :args format-args + :parent (current-trace) + :retlist nil))) + +(defslyfun trace-or-lose (id) + (when (<= 0 id (1- (length *traces*))) + (or (aref *traces* id) + (error "No trace with id ~a" id)))) + +(defslyfun report-partial-tree (key) + (unless (equal key *visitor-key*) + (setq *visitor-idx* 0 + *visitor-key* key)) + (let* ((recently-finished + (loop with i = 0 + for trace in *unfinished-traces* + while (< i *traces-per-report*) + when (completed-p trace) + collect trace + and do + (incf i) + (setq *unfinished-traces* + (remove trace *unfinished-traces*)))) + (new (loop for i + from (length recently-finished) + below *traces-per-report* + while (< *visitor-idx* (length *traces*)) + for trace = (aref *traces* *visitor-idx*) + collect trace + unless (completed-p trace) + do (push trace *unfinished-traces*) + do (incf *visitor-idx*)))) + (list + (mapcar #'describe-trace-for-emacs + (append recently-finished new)) + (- (length *traces*) *visitor-idx*) + key))) + +(defslyfun report-specs () + (mapcar (lambda (spec) + (cons (string-downcase (present-for-emacs spec)) + spec)) + (sort (copy-list *traced-specs*) + #'string< + :key #'princ-to-string))) + +(defslyfun report-total () + (length *traces*)) + +(defslyfun clear-trace-tree () + (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) + *visitor-key* nil + *unfinished-traces* nil) + (slynk-backend:call-with-lock-held + *trace-lock* + #'(lambda () (setf (fill-pointer *traces*) 0))) + nil) + +(defslyfun trace-part-or-lose (id part-id type) + (let* ((trace (trace-or-lose id)) + (l (ecase type + (:arg (args-of trace)) + (:retval (slynk::ensure-list (retlist-of trace)))))) + (or (nth part-id l) + (error "Cannot find a trace part with id ~a and part-id ~a" + id part-id)))) + +(defslyfun trace-arguments-or-lose (trace-id) + (values-list (args-of (trace-or-lose trace-id)))) + +(defslyfun inspect-trace-part (trace-id part-id type) + (slynk::inspect-object + (trace-part-or-lose trace-id part-id type))) + +(defslyfun pprint-trace-part (trace-id part-id type) + (slynk::slynk-pprint (list (trace-part-or-lose trace-id part-id type)))) + +(defslyfun describe-trace-part (trace-id part-id type) + (slynk::describe-to-string (trace-part-or-lose trace-id part-id type))) + +(defslyfun inspect-trace (trace-id) + (slynk::inspect-object (trace-or-lose trace-id))) + +(defslyfun trace-location (trace-id) + (slynk-backend:find-source-location (function-of (trace-or-lose trace-id)))) + +(defslyfun dialog-trace (spec) + (let ((function nil)) + (flet ((before-hook (args) + (setf (current-trace) (make-instance 'trace-entry + :spec spec + :function (or function + spec) + :args args + :parent (current-trace)))) + (after-hook (returned-values) + (let ((trace (current-trace))) + (when trace + (with-slots (retlist parent printed-retlist) trace + ;; the current trace might have been wiped away if the + ;; user cleared the tree in the meantime. no biggie, + ;; don't do anything. + ;; + (setf retlist returned-values + printed-retlist + (mapcar (lambda (obj) + (present-for-emacs obj #'slynk-pprint-to-line)) + (slynk::ensure-list retlist)) + (current-trace) parent)))))) + (when (dialog-traced-p spec) + (warn "~a is apparently already traced! Untracing and retracing." spec) + (dialog-untrace spec)) + (setq function + (slynk-backend:wrap spec 'trace-dialog + :before #'before-hook + :after #'after-hook)) + (pushnew spec *traced-specs*) + (format nil "~a is now traced for trace dialog" spec)))) + +(defslyfun dialog-untrace (spec) + (with-simple-restart + (continue "Never mind, i really want this trace to go away") + (slynk-backend:unwrap spec 'trace-dialog)) + (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) + (format nil "~a is now untraced for trace dialog" spec)) + +(defslyfun dialog-toggle-trace (spec) + (if (dialog-traced-p spec) + (dialog-untrace spec) + (dialog-trace spec))) + +(defslyfun dialog-traced-p (spec) + (find spec *traced-specs* :test #'equal)) + +(defslyfun dialog-untrace-all () + (let ((regular (length (trace))) + (dialog (length *traced-specs*))) + (untrace) + (mapcar #'dialog-untrace *traced-specs*) + (cons regular dialog))) + + + + +;;;; Hook onto emacs +;;;; +(setq slynk:*after-toggle-trace-hook* + #'(lambda (spec traced-p) + (when *dialog-trace-follows-trace* + (cond (traced-p + (dialog-trace spec) + "traced for trace dialog as well") + (t + (dialog-untrace spec) + "untraced for the trace dialog as well"))))) + + +;;;; Instrumentation +;;;; +(defmacro instrument (x &optional (id (gensym "EXPLICIT-INSTRUMENT-")) ) + (let ((values-sym (gensym))) + `(let ((,values-sym (multiple-value-list ,x))) + (trace-format (format nil "~a: ~a" ',id "~a => ~{~a~^, ~}") ',x + ,values-sym) + (values-list ,values-sym)))) + +(provide :slynk/trace-dialog) blob - /dev/null blob + 2228752d51fbddc3e73b6dbda0f1795d35233fa9 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contrib/sylvesters.txt @@ -0,0 +1,177 @@ + ( \ + \ \ + / / |\\ + / / .-`````-. / ^`-. + \ \ / \_/ {|} `o + \ \ / .---. \\ _ ,--' + \ \/ / \, \( `^^^ @@@@ + \ \/\ (\ ) + \ ) \ ) \ \ + ) /__ \__ ) (\ \___ +jgs (___)))__))(__))(__))) + + _,'| _.-''``-...___..--';) + /_ \'. __..-' , ,--...--''' + <\ .`--''' ` /' + fxlee `-';' ; ; ; + __...--'' ___...--_..' .;.' + (,__....----''' (,..--'' @@@@ + + + @@@@ + . + ("`-''-/").___..--''"`-._ + `6_ 6 ) `-. ( ).`-.__.`) + (_Y_.)' ._ ) `._ `. ``-..-' + _..`--'_..-_/ /--'_.' ,' + (il),-'' (li),' ((!.-' fxlee + + + @@@@ + |\ _,,,---,,_ + /,`.-'`' -. ;-;;,_ + |,4- ) )-,_..;\ ( `'-' + '---''(_/--' `-'\_) + fxlee + + @@@@ + . + __..--''``\--....___ _..,_ + _.-' .-/"; ` ``<._ ``-+'~=. + _.-' _..--.'_ \ `(^) ) + ((..-' (< _ ;_..__ ; `' + `-._,_)' ``--...____..-' + fxlee + + (`.-,') + .-' ; + _.-' , `,- + fxlee _ _.-' .' /._ + .' ` _.-. / ,'._;) + ( . )-| ( + )`,_ ,'_,' \_;) @@@@ + ('_ _,'.' (___,)) + `-:;.-' + + |\___/| + ) ( . ' + =\ /= + )===( * + / \ + | | @@@@ + / \ + \ / + jgs_/\_/\__ _/_/\_/\_/\_/\_/\_/\_/\_/\_/\_ + | | | |( ( | | | | | | | | | | + | | | | ) ) | | | | | | | | | | + | | | |(_( | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + + |\___/| + =) ^Y^ (= . ' + \ ^ / + )=*=( * + / \ + | | + /| | | |\ @@@@ + \| | |_|/\ + jgs_/\_//_// ___/\_/\_/\_/\_/\_/\_/\_/\_/\_ + | | | | \_) | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + + * + @@@@ + . . + * _ + |\___/| \\ + =) ^Y^ (= |\_/| || ' + \ ^ / )a a '._.-""""-. // + )=*=( =\T_= / ~ ~ \// + / \ `"`\ ~ / ~ / + | | |~ \ | ~/ + /| | | |\ \ ~/- \ ~\ + \| | |_|/| || | // /` + jgs_/\_//_// __//\_/\_/\_((_|\((_//\_/\_/\_ + | | | | \_) | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + | | | | | | | | | | | | | | | + + * + @@@@ + . . + * + |\___/| /\___/\ + ) ( ) ~( . ' + =\ /= =\~ /= + )===( ) ~ ( + / \ / \ + | | ) ~ ( + / \ / ~ \ + \ / \~ ~/ + jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_ + | | | |( ( | | | )) | | | | | | + | | | | ) ) | | |//| | | | | | | + | | | |(_( | | (( | | | | | | | + | | | | | | | |\)| | | | | | | + | | | | | | | | | | | | | | | + + * + @@@@ + . . + * + /\/|_ __/\\ + / -\ /- ~\ . ' + \ = Y =T_ = / + )==*(` `) ~ \ + / \ / \ + | | ) ~ ( + / \ / ~ \ + \ / \~ ~/ + jgs_/\_/\__ _/_/\_/\__~__/_/\_/\_/\_/\_/\_ + | | | | ) ) | | | (( | | | | | | + | | | |( ( | | | \\ | | | | | | + | | | | )_) | | | |))| | | | | | + | | | | | | | | (/ | | | | | | + | | | | | | | | | | | | | | | + + |\_._/| + | o o | + ( T ) + .^`-^-'^. @@@@ + `. ; .' + | | | | | + ((_((|))_)) + hjw + + |,\__/| + | o o| + ( T ) @@@@ + .^`--^'^. + `. ; .' + | | | | | + ((_((|))_)) + hjw + + |\__/,| + |o o | + ( T ) + .^`^--'^. @@@@ + `. ; .' + | | | | | + ((_((|))_)) + hjw + + |\_._/| + | 0 0 | + ( T ) @@@@ + .^`-^-'^. + `. ; .' + | | | | | + ((_((|))_)) + hjw blob - /dev/null blob + 24508558b96ec0b2595ae656d2b953baef6c0242 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/contributors.info @@ -0,0 +1,44 @@ +This is contributors.info, produced by makeinfo version 6.8 from +contributors.texi. + +Helmut Eller João Távora Luke Gorrie +Tobias C. Rittweiler Stas Boukarev Marco Baringer +Matthias Koeppe Nikodemus Siivola Alan Ruttenberg +Attila Lendvai Luís Borges de Dan Barlow + Oliveira +Andras Simon Martin Simmons Geo Carncross +Christophe Rhodes Peter Seibel Mark Evenson +Juho Snellman Douglas Crosher Wolfgang Jenkner +R Primus Javier Olaechea Edi Weitz +Zach Shaftel James Bielman Daniel Kochmanski +Terje Norderhaug Vladimir Sedach Juan Jose Garcia + Ripoll +Alexander Artemenko Spenser Truex Nathan Trapuzzano +Brian Downing Mark Jeffrey Cunningham +Espen Wiborg Paul M. Rodriguez Masataro Asai +Jan Moringen Sébastien Villemot Samuel Freilich +Raymond Toy Pierre Neidhardt Phil Hargett +Paulo Madeira Kris Katterjohn Jonas Bernoulli +Ivan Shvedunov Gábor Melis Francois-Rene Rideau +Christophe Junke Bozhidar Batsov Bart Botta +Wilfredo Tianxiang Xiong Syohei YOSHIDA +Velázquez-Rodríguez +Stefan Monnier Rommel MARTINEZ Pavel Kulyov +Paul A. Patience Olof-Joachim Frahm Mike Clarke +Michał Herda Mark H. David Mario Lang +Manfred Bergmann Leo Liu Koga Kazuo +Jon Oddie John Stracke Joe Robertson +Grant Shangreaux Graham Dobbins Eric Timmons +Douglas Katzman Dmitry Igrishin Dmitrii Korobeinikov +Deokhwan Kim Denis Budyak Chunyang Xu +Cayman Angelo Rossi Andrew Kirkpatrick + + +Tag Table: + +End Tag Table + + +Local Variables: +coding: utf-8 +End: blob - /dev/null blob + 1591d4df600a26725f7ad97edb7a55ddfb4328c8 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* SLY: (sly). Common-Lisp IDE blob - /dev/null blob + 50424e38442e5bab82bc32e2fe7f743bc522809d (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/stickers-1-placed-stickers.png differ blob - /dev/null blob + a9dc79b9749b5cfbb09cb11b1e7191e86d9fc8fa (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/stickers-2-armed-stickers.png differ blob - /dev/null blob + 8af3659b941bdd32dbddd8d9dee84aa48071a364 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/stickers-3-replay-stickers.png differ blob - /dev/null blob + b7131b6e6fec1d5f8fd251bdc91a86e5a6465b0f (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/stickers-4-breaking-stickers.png differ blob - /dev/null blob + 2e9d9058b6fa3f94099fc979c41665ed9f752933 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/stickers-5-fetch-recordings.png differ blob - /dev/null blob + f1c01a523260b51fea6fc565e0d36fbf24a6dafe (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-1.png differ blob - /dev/null blob + 23b64a8db433e7fb0d8c2838bafcaf1d6e985c5e (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-2.png differ blob - /dev/null blob + 144dbff72c4a2fb9e60291666ba59c7684be0d20 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-3.png differ blob - /dev/null blob + 7f6d6658518456ac5033e74b8fe65c208e29f659 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-4.png differ blob - /dev/null blob + 835eb0074d0dc2122d754c814a5d23c5d9b241b3 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-5.png differ blob - /dev/null blob + eceac2008f2ea84843faa09f10b568413562eb50 (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/images/tutorial-6.png differ blob - /dev/null blob + 5529475bf8d5cadbab7f68dadbf6f793d01b7c02 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/.nosearch @@ -0,0 +1 @@ +;; normal-top-level-add-subdirs-to-load-path needs this file blob - /dev/null blob + fd46f2e7debafb37c7598d677d91c6bf7ca868c0 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/hyperspec.el @@ -0,0 +1,2508 @@ +;;; hyperspec.el --- Browse documentation from the Common Lisp HyperSpec -*- lexical-binding: t; -*- + +;; Copyright 1997 Naggum Software + +;; Author: Erik Naggum +;; Keywords: lisp + +;; This file is not part of GNU Emacs, but distributed under the same +;; conditions as GNU Emacs, and is useless without 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: + +;; Kent Pitman and Xanalys Inc. have made the text of American National +;; Standard for Information Technology -- Programming Language -- Common +;; Lisp, ANSI X3.226-1994 available on the WWW, in the form of the Common +;; Lisp HyperSpec. This package makes it convenient to peruse this +;; documentation from within Emacs. + +;;; Code: + +(require 'cl-lib nil t) +(require 'cl-lib "lib/cl-lib") +(require 'browse-url) ;you need the Emacs 20 version +(require 'thingatpt) + +(defvar common-lisp-hyperspec-root + "http://www.lispworks.com/reference/HyperSpec/" + "The root of the Common Lisp HyperSpec URL. +If you copy the HyperSpec to your local system, set this variable to +something like \"file://usr/local/doc/HyperSpec/\".") + +;;; Added variable for CLHS symbol table. See details below. +;;; +;;; 20011201 Edi Weitz + +(defvar common-lisp-hyperspec-symbol-table nil + "The HyperSpec symbol table file. +If you copy the HyperSpec to your local system, set this variable to +the location of the symbol table which is usually \"Map_Sym.txt\" +or \"Symbol-Table.text\".") + +(defvar common-lisp-hyperspec-history nil + "History of symbols looked up in the Common Lisp HyperSpec.") + +(defvar common-lisp-hyperspec--symbols (make-hash-table :test 'equal) + "Map a symbol name to its list of relative URLs.") + +;; Lookup NAME in 'common-lisp-hyperspec--symbols´ +(defun common-lisp-hyperspec--find (name) + "Get the relative url of a Common Lisp symbol NAME." + (gethash name common-lisp-hyperspec--symbols)) + +(defun common-lisp-hyperspec--insert (name relative-url) + "Insert CL symbol NAME and RELATIVE-URL into master table." + (cl-pushnew relative-url + (gethash name common-lisp-hyperspec--symbols) + :test #'equal)) + +(defun common-lisp-hyperspec--strip-cl-package (name) + (if (string-match "^\\([^:]*\\)::?\\([^:]*\\)$" name) + (let ((package-name (match-string 1 name)) + (symbol-name (match-string 2 name))) + (if (member (downcase package-name) + '("cl" "common-lisp")) + symbol-name + name)) + name)) + +;; Choose the symbol at point or read symbol-name from the minibuffer. +(defun common-lisp-hyperspec-read-symbol-name (&optional symbol-at-point) + (let* ((symbol-at-point (or symbol-at-point (thing-at-point 'symbol))) + (stripped-symbol (and symbol-at-point + (common-lisp-hyperspec--strip-cl-package + (downcase symbol-at-point))))) + (cond ((and stripped-symbol + (common-lisp-hyperspec--find stripped-symbol)) + stripped-symbol) + (t + (completing-read "Look up symbol in Common Lisp HyperSpec: " + common-lisp-hyperspec--symbols nil t + stripped-symbol + 'common-lisp-hyperspec-history))))) + +;; FIXME: is the (sleep-for 1.5) a actually needed? +(defun common-lisp-hyperspec (symbol-name) + "View the documentation on SYMBOL-NAME from the Common Lisp HyperSpec. +If SYMBOL-NAME has more than one definition, all of them are displayed with +your favorite browser in sequence. The browser should have a \"back\" +function to view the separate definitions. + +The Common Lisp HyperSpec is the full ANSI Standard Common Lisp, provided +by Kent Pitman and Xanalys Inc. By default, the Xanalys Web site is +visited to retrieve the information. Xanalys Inc. allows you to transfer +the entire Common Lisp HyperSpec to your own site under certain conditions. +Visit http://www.lispworks.com/reference/HyperSpec/ for more information. +If you copy the HyperSpec to another location, customize the variable +`common-lisp-hyperspec-root' to point to that location." + (interactive (list (common-lisp-hyperspec-read-symbol-name))) + (let ((name (common-lisp-hyperspec--strip-cl-package + (downcase symbol-name)))) + (cl-maplist (lambda (entry) + (browse-url (concat common-lisp-hyperspec-root "Body/" + (car entry))) + (when (cdr entry) + (sleep-for 1.5))) + (or (common-lisp-hyperspec--find name) + (error "The symbol `%s' is not defined in Common Lisp" + symbol-name))))) + +;;; Added dynamic lookup of symbol in CLHS symbol table +;;; +;;; 20011202 Edi Weitz + +;;; Replaced symbol table for v 4.0 with the one for v 6.0 +;;; (which is now online at Xanalys' site) +;;; +;;; 20020213 Edi Weitz + +(defun common-lisp-hyperspec--get-one-line () + (prog1 + (cl-delete ?\n (thing-at-point 'line)) + (forward-line))) + +(defun common-lisp-hyperspec--parse-map-file (file) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (let ((result '())) + (while (< (point) (point-max)) + (let* ((symbol-name (downcase (common-lisp-hyperspec--get-one-line))) + (relative-url (common-lisp-hyperspec--get-one-line)) + (file (file-name-nondirectory relative-url))) + (push (list symbol-name file) + result))) + (reverse result)))) + +(mapc (lambda (entry) + (common-lisp-hyperspec--insert (car entry) (cadr entry))) + (if common-lisp-hyperspec-symbol-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-symbol-table) + '(("&allow-other-keys" "03_da.htm") + ("&aux" "03_da.htm") + ("&body" "03_dd.htm") + ("&environment" "03_dd.htm") + ("&key" "03_da.htm") + ("&optional" "03_da.htm") + ("&rest" "03_da.htm") + ("&whole" "03_dd.htm") + ("*" "a_st.htm") + ("**" "v__stst_.htm") + ("***" "v__stst_.htm") + ("*break-on-signals*" "v_break_.htm") + ("*compile-file-pathname*" "v_cmp_fi.htm") + ("*compile-file-truename*" "v_cmp_fi.htm") + ("*compile-print*" "v_cmp_pr.htm") + ("*compile-verbose*" "v_cmp_pr.htm") + ("*debug-io*" "v_debug_.htm") + ("*debugger-hook*" "v_debugg.htm") + ("*default-pathname-defaults*" "v_defaul.htm") + ("*error-output*" "v_debug_.htm") + ("*features*" "v_featur.htm") + ("*gensym-counter*" "v_gensym.htm") + ("*load-pathname*" "v_ld_pns.htm") + ("*load-print*" "v_ld_prs.htm") + ("*load-truename*" "v_ld_pns.htm") + ("*load-verbose*" "v_ld_prs.htm") + ("*macroexpand-hook*" "v_mexp_h.htm") + ("*modules*" "v_module.htm") + ("*package*" "v_pkg.htm") + ("*print-array*" "v_pr_ar.htm") + ("*print-base*" "v_pr_bas.htm") + ("*print-case*" "v_pr_cas.htm") + ("*print-circle*" "v_pr_cir.htm") + ("*print-escape*" "v_pr_esc.htm") + ("*print-gensym*" "v_pr_gen.htm") + ("*print-length*" "v_pr_lev.htm") + ("*print-level*" "v_pr_lev.htm") + ("*print-lines*" "v_pr_lin.htm") + ("*print-miser-width*" "v_pr_mis.htm") + ("*print-pprint-dispatch*" "v_pr_ppr.htm") + ("*print-pretty*" "v_pr_pre.htm") + ("*print-radix*" "v_pr_bas.htm") + ("*print-readably*" "v_pr_rda.htm") + ("*print-right-margin*" "v_pr_rig.htm") + ("*query-io*" "v_debug_.htm") + ("*random-state*" "v_rnd_st.htm") + ("*read-base*" "v_rd_bas.htm") + ("*read-default-float-format*" "v_rd_def.htm") + ("*read-eval*" "v_rd_eva.htm") + ("*read-suppress*" "v_rd_sup.htm") + ("*readtable*" "v_rdtabl.htm") + ("*standard-input*" "v_debug_.htm") + ("*standard-output*" "v_debug_.htm") + ("*terminal-io*" "v_termin.htm") + ("*trace-output*" "v_debug_.htm") + ("+" "a_pl.htm") + ("++" "v_pl_plp.htm") + ("+++" "v_pl_plp.htm") + ("-" "a__.htm") + ("/" "a_sl.htm") + ("//" "v_sl_sls.htm") + ("///" "v_sl_sls.htm") + ("/=" "f_eq_sle.htm") + ("1+" "f_1pl_1_.htm") + ("1-" "f_1pl_1_.htm") + ("<" "f_eq_sle.htm") + ("<=" "f_eq_sle.htm") + ("=" "f_eq_sle.htm") + (">" "f_eq_sle.htm") + (">=" "f_eq_sle.htm") + ("abort" "a_abort.htm") + ("abs" "f_abs.htm") + ("acons" "f_acons.htm") + ("acos" "f_asin_.htm") + ("acosh" "f_sinh_.htm") + ("add-method" "f_add_me.htm") + ("adjoin" "f_adjoin.htm") + ("adjust-array" "f_adjust.htm") + ("adjustable-array-p" "f_adju_1.htm") + ("allocate-instance" "f_alloca.htm") + ("alpha-char-p" "f_alpha_.htm") + ("alphanumericp" "f_alphan.htm") + ("and" "a_and.htm") + ("append" "f_append.htm") + ("apply" "f_apply.htm") + ("apropos" "f_apropo.htm") + ("apropos-list" "f_apropo.htm") + ("aref" "f_aref.htm") + ("arithmetic-error" "e_arithm.htm") + ("arithmetic-error-operands" "f_arithm.htm") + ("arithmetic-error-operation" "f_arithm.htm") + ("array" "t_array.htm") + ("array-dimension" "f_ar_dim.htm") + ("array-dimension-limit" "v_ar_dim.htm") + ("array-dimensions" "f_ar_d_1.htm") + ("array-displacement" "f_ar_dis.htm") + ("array-element-type" "f_ar_ele.htm") + ("array-has-fill-pointer-p" "f_ar_has.htm") + ("array-in-bounds-p" "f_ar_in_.htm") + ("array-rank" "f_ar_ran.htm") + ("array-rank-limit" "v_ar_ran.htm") + ("array-row-major-index" "f_ar_row.htm") + ("array-total-size" "f_ar_tot.htm") + ("array-total-size-limit" "v_ar_tot.htm") + ("arrayp" "f_arrayp.htm") + ("ash" "f_ash.htm") + ("asin" "f_asin_.htm") + ("asinh" "f_sinh_.htm") + ("assert" "m_assert.htm") + ("assoc" "f_assocc.htm") + ("assoc-if" "f_assocc.htm") + ("assoc-if-not" "f_assocc.htm") + ("atan" "f_asin_.htm") + ("atanh" "f_sinh_.htm") + ("atom" "a_atom.htm") + ("base-char" "t_base_c.htm") + ("base-string" "t_base_s.htm") + ("bignum" "t_bignum.htm") + ("bit" "a_bit.htm") + ("bit-and" "f_bt_and.htm") + ("bit-andc1" "f_bt_and.htm") + ("bit-andc2" "f_bt_and.htm") + ("bit-eqv" "f_bt_and.htm") + ("bit-ior" "f_bt_and.htm") + ("bit-nand" "f_bt_and.htm") + ("bit-nor" "f_bt_and.htm") + ("bit-not" "f_bt_and.htm") + ("bit-orc1" "f_bt_and.htm") + ("bit-orc2" "f_bt_and.htm") + ("bit-vector" "t_bt_vec.htm") + ("bit-vector-p" "f_bt_vec.htm") + ("bit-xor" "f_bt_and.htm") + ("block" "s_block.htm") + ("boole" "f_boole.htm") + ("boole-1" "v_b_1_b.htm") + ("boole-2" "v_b_1_b.htm") + ("boole-and" "v_b_1_b.htm") + ("boole-andc1" "v_b_1_b.htm") + ("boole-andc2" "v_b_1_b.htm") + ("boole-c1" "v_b_1_b.htm") + ("boole-c2" "v_b_1_b.htm") + ("boole-clr" "v_b_1_b.htm") + ("boole-eqv" "v_b_1_b.htm") + ("boole-ior" "v_b_1_b.htm") + ("boole-nand" "v_b_1_b.htm") + ("boole-nor" "v_b_1_b.htm") + ("boole-orc1" "v_b_1_b.htm") + ("boole-orc2" "v_b_1_b.htm") + ("boole-set" "v_b_1_b.htm") + ("boole-xor" "v_b_1_b.htm") + ("boolean" "t_ban.htm") + ("both-case-p" "f_upper_.htm") + ("boundp" "f_boundp.htm") + ("break" "f_break.htm") + ("broadcast-stream" "t_broadc.htm") + ("broadcast-stream-streams" "f_broadc.htm") + ("built-in-class" "t_built_.htm") + ("butlast" "f_butlas.htm") + ("byte" "f_by_by.htm") + ("byte-position" "f_by_by.htm") + ("byte-size" "f_by_by.htm") + ("caaaar" "f_car_c.htm") + ("caaadr" "f_car_c.htm") + ("caaar" "f_car_c.htm") + ("caadar" "f_car_c.htm") + ("caaddr" "f_car_c.htm") + ("caadr" "f_car_c.htm") + ("caar" "f_car_c.htm") + ("cadaar" "f_car_c.htm") + ("cadadr" "f_car_c.htm") + ("cadar" "f_car_c.htm") + ("caddar" "f_car_c.htm") + ("cadddr" "f_car_c.htm") + ("caddr" "f_car_c.htm") + ("cadr" "f_car_c.htm") + ("call-arguments-limit" "v_call_a.htm") + ("call-method" "m_call_m.htm") + ("call-next-method" "f_call_n.htm") + ("car" "f_car_c.htm") + ("case" "m_case_.htm") + ("catch" "s_catch.htm") + ("ccase" "m_case_.htm") + ("cdaaar" "f_car_c.htm") + ("cdaadr" "f_car_c.htm") + ("cdaar" "f_car_c.htm") + ("cdadar" "f_car_c.htm") + ("cdaddr" "f_car_c.htm") + ("cdadr" "f_car_c.htm") + ("cdar" "f_car_c.htm") + ("cddaar" "f_car_c.htm") + ("cddadr" "f_car_c.htm") + ("cddar" "f_car_c.htm") + ("cdddar" "f_car_c.htm") + ("cddddr" "f_car_c.htm") + ("cdddr" "f_car_c.htm") + ("cddr" "f_car_c.htm") + ("cdr" "f_car_c.htm") + ("ceiling" "f_floorc.htm") + ("cell-error" "e_cell_e.htm") + ("cell-error-name" "f_cell_e.htm") + ("cerror" "f_cerror.htm") + ("change-class" "f_chg_cl.htm") + ("char" "f_char_.htm") + ("char-code" "f_char_c.htm") + ("char-code-limit" "v_char_c.htm") + ("char-downcase" "f_char_u.htm") + ("char-equal" "f_chareq.htm") + ("char-greaterp" "f_chareq.htm") + ("char-int" "f_char_i.htm") + ("char-lessp" "f_chareq.htm") + ("char-name" "f_char_n.htm") + ("char-not-equal" "f_chareq.htm") + ("char-not-greaterp" "f_chareq.htm") + ("char-not-lessp" "f_chareq.htm") + ("char-upcase" "f_char_u.htm") + ("char/=" "f_chareq.htm") + ("char<" "f_chareq.htm") + ("char<=" "f_chareq.htm") + ("char=" "f_chareq.htm") + ("char>" "f_chareq.htm") + ("char>=" "f_chareq.htm") + ("character" "a_ch.htm") + ("characterp" "f_chp.htm") + ("check-type" "m_check_.htm") + ("cis" "f_cis.htm") + ("class" "t_class.htm") + ("class-name" "f_class_.htm") + ("class-of" "f_clas_1.htm") + ("clear-input" "f_clear_.htm") + ("clear-output" "f_finish.htm") + ("close" "f_close.htm") + ("clrhash" "f_clrhas.htm") + ("code-char" "f_code_c.htm") + ("coerce" "f_coerce.htm") + ("compilation-speed" "d_optimi.htm") + ("compile" "f_cmp.htm") + ("compile-file" "f_cmp_fi.htm") + ("compile-file-pathname" "f_cmp__1.htm") + ("compiled-function" "t_cmpd_f.htm") + ("compiled-function-p" "f_cmpd_f.htm") + ("compiler-macro" "f_docume.htm") + ("compiler-macro-function" "f_cmp_ma.htm") + ("complement" "f_comple.htm") + ("complex" "a_comple.htm") + ("complexp" "f_comp_3.htm") + ("compute-applicable-methods" "f_comput.htm") + ("compute-restarts" "f_comp_1.htm") + ("concatenate" "f_concat.htm") + ("concatenated-stream" "t_concat.htm") + ("concatenated-stream-streams" "f_conc_1.htm") + ("cond" "m_cond.htm") + ("condition" "e_cnd.htm") + ("conjugate" "f_conjug.htm") + ("cons" "a_cons.htm") + ("consp" "f_consp.htm") + ("constantly" "f_cons_1.htm") + ("constantp" "f_consta.htm") + ("continue" "a_contin.htm") + ("control-error" "e_contro.htm") + ("copy-alist" "f_cp_ali.htm") + ("copy-list" "f_cp_lis.htm") + ("copy-pprint-dispatch" "f_cp_ppr.htm") + ("copy-readtable" "f_cp_rdt.htm") + ("copy-seq" "f_cp_seq.htm") + ("copy-structure" "f_cp_stu.htm") + ("copy-symbol" "f_cp_sym.htm") + ("copy-tree" "f_cp_tre.htm") + ("cos" "f_sin_c.htm") + ("cosh" "f_sinh_.htm") + ("count" "f_countc.htm") + ("count-if" "f_countc.htm") + ("count-if-not" "f_countc.htm") + ("ctypecase" "m_tpcase.htm") + ("debug" "d_optimi.htm") + ("decf" "m_incf_.htm") + ("declaim" "m_declai.htm") + ("declaration" "d_declar.htm") + ("declare" "s_declar.htm") + ("decode-float" "f_dec_fl.htm") + ("decode-universal-time" "f_dec_un.htm") + ("defclass" "m_defcla.htm") + ("defconstant" "m_defcon.htm") + ("defgeneric" "m_defgen.htm") + ("define-compiler-macro" "m_define.htm") + ("define-condition" "m_defi_5.htm") + ("define-method-combination" "m_defi_4.htm") + ("define-modify-macro" "m_defi_2.htm") + ("define-setf-expander" "m_defi_3.htm") + ("define-symbol-macro" "m_defi_1.htm") + ("defmacro" "m_defmac.htm") + ("defmethod" "m_defmet.htm") + ("defpackage" "m_defpkg.htm") + ("defparameter" "m_defpar.htm") + ("defsetf" "m_defset.htm") + ("defstruct" "m_defstr.htm") + ("deftype" "m_deftp.htm") + ("defun" "m_defun.htm") + ("defvar" "m_defpar.htm") + ("delete" "f_rm_rm.htm") + ("delete-duplicates" "f_rm_dup.htm") + ("delete-file" "f_del_fi.htm") + ("delete-if" "f_rm_rm.htm") + ("delete-if-not" "f_rm_rm.htm") + ("delete-package" "f_del_pk.htm") + ("denominator" "f_numera.htm") + ("deposit-field" "f_deposi.htm") + ("describe" "f_descri.htm") + ("describe-object" "f_desc_1.htm") + ("destructuring-bind" "m_destru.htm") + ("digit-char" "f_digit_.htm") + ("digit-char-p" "f_digi_1.htm") + ("directory" "f_dir.htm") + ("directory-namestring" "f_namest.htm") + ("disassemble" "f_disass.htm") + ("division-by-zero" "e_divisi.htm") + ("do" "m_do_do.htm") + ("do*" "m_do_do.htm") + ("do-all-symbols" "m_do_sym.htm") + ("do-external-symbols" "m_do_sym.htm") + ("do-symbols" "m_do_sym.htm") + ("documentation" "f_docume.htm") + ("dolist" "m_dolist.htm") + ("dotimes" "m_dotime.htm") + ("double-float" "t_short_.htm") + ("double-float-epsilon" "v_short_.htm") + ("double-float-negative-epsilon" "v_short_.htm") + ("dpb" "f_dpb.htm") + ("dribble" "f_dribbl.htm") + ("dynamic-extent" "d_dynami.htm") + ("ecase" "m_case_.htm") + ("echo-stream" "t_echo_s.htm") + ("echo-stream-input-stream" "f_echo_s.htm") + ("echo-stream-output-stream" "f_echo_s.htm") + ("ed" "f_ed.htm") + ("eighth" "f_firstc.htm") + ("elt" "f_elt.htm") + ("encode-universal-time" "f_encode.htm") + ("end-of-file" "e_end_of.htm") + ("endp" "f_endp.htm") + ("enough-namestring" "f_namest.htm") + ("ensure-directories-exist" "f_ensu_1.htm") + ("ensure-generic-function" "f_ensure.htm") + ("eq" "f_eq.htm") + ("eql" "a_eql.htm") + ("equal" "f_equal.htm") + ("equalp" "f_equalp.htm") + ("error" "a_error.htm") + ("etypecase" "m_tpcase.htm") + ("eval" "f_eval.htm") + ("eval-when" "s_eval_w.htm") + ("evenp" "f_evenpc.htm") + ("every" "f_everyc.htm") + ("exp" "f_exp_e.htm") + ("export" "f_export.htm") + ("expt" "f_exp_e.htm") + ("extended-char" "t_extend.htm") + ("fboundp" "f_fbound.htm") + ("fceiling" "f_floorc.htm") + ("fdefinition" "f_fdefin.htm") + ("ffloor" "f_floorc.htm") + ("fifth" "f_firstc.htm") + ("file-author" "f_file_a.htm") + ("file-error" "e_file_e.htm") + ("file-error-pathname" "f_file_e.htm") + ("file-length" "f_file_l.htm") + ("file-namestring" "f_namest.htm") + ("file-position" "f_file_p.htm") + ("file-stream" "t_file_s.htm") + ("file-string-length" "f_file_s.htm") + ("file-write-date" "f_file_w.htm") + ("fill" "f_fill.htm") + ("fill-pointer" "f_fill_p.htm") + ("find" "f_find_.htm") + ("find-all-symbols" "f_find_a.htm") + ("find-class" "f_find_c.htm") + ("find-if" "f_find_.htm") + ("find-if-not" "f_find_.htm") + ("find-method" "f_find_m.htm") + ("find-package" "f_find_p.htm") + ("find-restart" "f_find_r.htm") + ("find-symbol" "f_find_s.htm") + ("finish-output" "f_finish.htm") + ("first" "f_firstc.htm") + ("fixnum" "t_fixnum.htm") + ("flet" "s_flet_.htm") + ("float" "a_float.htm") + ("float-digits" "f_dec_fl.htm") + ("float-precision" "f_dec_fl.htm") + ("float-radix" "f_dec_fl.htm") + ("float-sign" "f_dec_fl.htm") + ("floating-point-inexact" "e_floa_1.htm") + ("floating-point-invalid-operation" "e_floati.htm") + ("floating-point-overflow" "e_floa_2.htm") + ("floating-point-underflow" "e_floa_3.htm") + ("floatp" "f_floatp.htm") + ("floor" "f_floorc.htm") + ("fmakunbound" "f_fmakun.htm") + ("force-output" "f_finish.htm") + ("format" "f_format.htm") + ("formatter" "m_format.htm") + ("fourth" "f_firstc.htm") + ("fresh-line" "f_terpri.htm") + ("fround" "f_floorc.htm") + ("ftruncate" "f_floorc.htm") + ("ftype" "d_ftype.htm") + ("funcall" "f_funcal.htm") + ("function" "a_fn.htm") + ("function-keywords" "f_fn_kwd.htm") + ("function-lambda-expression" "f_fn_lam.htm") + ("functionp" "f_fnp.htm") + ("gcd" "f_gcd.htm") + ("generic-function" "t_generi.htm") + ("gensym" "f_gensym.htm") + ("gentemp" "f_gentem.htm") + ("get" "f_get.htm") + ("get-decoded-time" "f_get_un.htm") + ("get-dispatch-macro-character" "f_set__1.htm") + ("get-internal-real-time" "f_get_in.htm") + ("get-internal-run-time" "f_get__1.htm") + ("get-macro-character" "f_set_ma.htm") + ("get-output-stream-string" "f_get_ou.htm") + ("get-properties" "f_get_pr.htm") + ("get-setf-expansion" "f_get_se.htm") + ("get-universal-time" "f_get_un.htm") + ("getf" "f_getf.htm") + ("gethash" "f_gethas.htm") + ("go" "s_go.htm") + ("graphic-char-p" "f_graphi.htm") + ("handler-bind" "m_handle.htm") + ("handler-case" "m_hand_1.htm") + ("hash-table" "t_hash_t.htm") + ("hash-table-count" "f_hash_1.htm") + ("hash-table-p" "f_hash_t.htm") + ("hash-table-rehash-size" "f_hash_2.htm") + ("hash-table-rehash-threshold" "f_hash_3.htm") + ("hash-table-size" "f_hash_4.htm") + ("hash-table-test" "f_hash_5.htm") + ("host-namestring" "f_namest.htm") + ("identity" "f_identi.htm") + ("if" "s_if.htm") + ("ignorable" "d_ignore.htm") + ("ignore" "d_ignore.htm") + ("ignore-errors" "m_ignore.htm") + ("imagpart" "f_realpa.htm") + ("import" "f_import.htm") + ("in-package" "m_in_pkg.htm") + ("incf" "m_incf_.htm") + ("initialize-instance" "f_init_i.htm") + ("inline" "d_inline.htm") + ("input-stream-p" "f_in_stm.htm") + ("inspect" "f_inspec.htm") + ("integer" "t_intege.htm") + ("integer-decode-float" "f_dec_fl.htm") + ("integer-length" "f_intege.htm") + ("integerp" "f_inte_1.htm") + ("interactive-stream-p" "f_intera.htm") + ("intern" "f_intern.htm") + ("internal-time-units-per-second" "v_intern.htm") + ("intersection" "f_isec_.htm") + ("invalid-method-error" "f_invali.htm") + ("invoke-debugger" "f_invoke.htm") + ("invoke-restart" "f_invo_1.htm") + ("invoke-restart-interactively" "f_invo_2.htm") + ("isqrt" "f_sqrt_.htm") + ("keyword" "t_kwd.htm") + ("keywordp" "f_kwdp.htm") + ("labels" "s_flet_.htm") + ("lambda" "a_lambda.htm") + ("lambda-list-keywords" "v_lambda.htm") + ("lambda-parameters-limit" "v_lamb_1.htm") + ("last" "f_last.htm") + ("lcm" "f_lcm.htm") + ("ldb" "f_ldb.htm") + ("ldb-test" "f_ldb_te.htm") + ("ldiff" "f_ldiffc.htm") + ("least-negative-double-float" "v_most_1.htm") + ("least-negative-long-float" "v_most_1.htm") + ("least-negative-normalized-double-float" "v_most_1.htm") + ("least-negative-normalized-long-float" "v_most_1.htm") + ("least-negative-normalized-short-float" "v_most_1.htm") + ("least-negative-normalized-single-float" "v_most_1.htm") + ("least-negative-short-float" "v_most_1.htm") + ("least-negative-single-float" "v_most_1.htm") + ("least-positive-double-float" "v_most_1.htm") + ("least-positive-long-float" "v_most_1.htm") + ("least-positive-normalized-double-float" "v_most_1.htm") + ("least-positive-normalized-long-float" "v_most_1.htm") + ("least-positive-normalized-short-float" "v_most_1.htm") + ("least-positive-normalized-single-float" "v_most_1.htm") + ("least-positive-short-float" "v_most_1.htm") + ("least-positive-single-float" "v_most_1.htm") + ("length" "f_length.htm") + ("let" "s_let_l.htm") + ("let*" "s_let_l.htm") + ("lisp-implementation-type" "f_lisp_i.htm") + ("lisp-implementation-version" "f_lisp_i.htm") + ("list" "a_list.htm") + ("list*" "f_list_.htm") + ("list-all-packages" "f_list_a.htm") + ("list-length" "f_list_l.htm") + ("listen" "f_listen.htm") + ("listp" "f_listp.htm") + ("load" "f_load.htm") + ("load-logical-pathname-translations" "f_ld_log.htm") + ("load-time-value" "s_ld_tim.htm") + ("locally" "s_locall.htm") + ("log" "f_log.htm") + ("logand" "f_logand.htm") + ("logandc1" "f_logand.htm") + ("logandc2" "f_logand.htm") + ("logbitp" "f_logbtp.htm") + ("logcount" "f_logcou.htm") + ("logeqv" "f_logand.htm") + ("logical-pathname" "a_logica.htm") + ("logical-pathname-translations" "f_logica.htm") + ("logior" "f_logand.htm") + ("lognand" "f_logand.htm") + ("lognor" "f_logand.htm") + ("lognot" "f_logand.htm") + ("logorc1" "f_logand.htm") + ("logorc2" "f_logand.htm") + ("logtest" "f_logtes.htm") + ("logxor" "f_logand.htm") + ("long-float" "t_short_.htm") + ("long-float-epsilon" "v_short_.htm") + ("long-float-negative-epsilon" "v_short_.htm") + ("long-site-name" "f_short_.htm") + ("loop" "m_loop.htm") + ("loop-finish" "m_loop_f.htm") + ("lower-case-p" "f_upper_.htm") + ("machine-instance" "f_mach_i.htm") + ("machine-type" "f_mach_t.htm") + ("machine-version" "f_mach_v.htm") + ("macro-function" "f_macro_.htm") + ("macroexpand" "f_mexp_.htm") + ("macroexpand-1" "f_mexp_.htm") + ("macrolet" "s_flet_.htm") + ("make-array" "f_mk_ar.htm") + ("make-broadcast-stream" "f_mk_bro.htm") + ("make-concatenated-stream" "f_mk_con.htm") + ("make-condition" "f_mk_cnd.htm") + ("make-dispatch-macro-character" "f_mk_dis.htm") + ("make-echo-stream" "f_mk_ech.htm") + ("make-hash-table" "f_mk_has.htm") + ("make-instance" "f_mk_ins.htm") + ("make-instances-obsolete" "f_mk_i_1.htm") + ("make-list" "f_mk_lis.htm") + ("make-load-form" "f_mk_ld_.htm") + ("make-load-form-saving-slots" "f_mk_l_1.htm") + ("make-method" "m_call_m.htm") + ("make-package" "f_mk_pkg.htm") + ("make-pathname" "f_mk_pn.htm") + ("make-random-state" "f_mk_rnd.htm") + ("make-sequence" "f_mk_seq.htm") + ("make-string" "f_mk_stg.htm") + ("make-string-input-stream" "f_mk_s_1.htm") + ("make-string-output-stream" "f_mk_s_2.htm") + ("make-symbol" "f_mk_sym.htm") + ("make-synonym-stream" "f_mk_syn.htm") + ("make-two-way-stream" "f_mk_two.htm") + ("makunbound" "f_makunb.htm") + ("map" "f_map.htm") + ("map-into" "f_map_in.htm") + ("mapc" "f_mapc_.htm") + ("mapcan" "f_mapc_.htm") + ("mapcar" "f_mapc_.htm") + ("mapcon" "f_mapc_.htm") + ("maphash" "f_maphas.htm") + ("mapl" "f_mapc_.htm") + ("maplist" "f_mapc_.htm") + ("mask-field" "f_mask_f.htm") + ("max" "f_max_m.htm") + ("member" "a_member.htm") + ("member-if" "f_mem_m.htm") + ("member-if-not" "f_mem_m.htm") + ("merge" "f_merge.htm") + ("merge-pathnames" "f_merge_.htm") + ("method" "t_method.htm") + ("method-combination" "a_method.htm") + ("method-combination-error" "f_meth_1.htm") + ("method-qualifiers" "f_method.htm") + ("min" "f_max_m.htm") + ("minusp" "f_minusp.htm") + ("mismatch" "f_mismat.htm") + ("mod" "a_mod.htm") + ("most-negative-double-float" "v_most_1.htm") + ("most-negative-fixnum" "v_most_p.htm") + ("most-negative-long-float" "v_most_1.htm") + ("most-negative-short-float" "v_most_1.htm") + ("most-negative-single-float" "v_most_1.htm") + ("most-positive-double-float" "v_most_1.htm") + ("most-positive-fixnum" "v_most_p.htm") + ("most-positive-long-float" "v_most_1.htm") + ("most-positive-short-float" "v_most_1.htm") + ("most-positive-single-float" "v_most_1.htm") + ("muffle-warning" "a_muffle.htm") + ("multiple-value-bind" "m_multip.htm") + ("multiple-value-call" "s_multip.htm") + ("multiple-value-list" "m_mult_1.htm") + ("multiple-value-prog1" "s_mult_1.htm") + ("multiple-value-setq" "m_mult_2.htm") + ("multiple-values-limit" "v_multip.htm") + ("name-char" "f_name_c.htm") + ("namestring" "f_namest.htm") + ("nbutlast" "f_butlas.htm") + ("nconc" "f_nconc.htm") + ("next-method-p" "f_next_m.htm") + ("nil" "a_nil.htm") + ("nintersection" "f_isec_.htm") + ("ninth" "f_firstc.htm") + ("no-applicable-method" "f_no_app.htm") + ("no-next-method" "f_no_nex.htm") + ("not" "a_not.htm") + ("notany" "f_everyc.htm") + ("notevery" "f_everyc.htm") + ("notinline" "d_inline.htm") + ("nreconc" "f_revapp.htm") + ("nreverse" "f_revers.htm") + ("nset-difference" "f_set_di.htm") + ("nset-exclusive-or" "f_set_ex.htm") + ("nstring-capitalize" "f_stg_up.htm") + ("nstring-downcase" "f_stg_up.htm") + ("nstring-upcase" "f_stg_up.htm") + ("nsublis" "f_sublis.htm") + ("nsubst" "f_substc.htm") + ("nsubst-if" "f_substc.htm") + ("nsubst-if-not" "f_substc.htm") + ("nsubstitute" "f_sbs_s.htm") + ("nsubstitute-if" "f_sbs_s.htm") + ("nsubstitute-if-not" "f_sbs_s.htm") + ("nth" "f_nth.htm") + ("nth-value" "m_nth_va.htm") + ("nthcdr" "f_nthcdr.htm") + ("null" "a_null.htm") + ("number" "t_number.htm") + ("numberp" "f_nump.htm") + ("numerator" "f_numera.htm") + ("nunion" "f_unionc.htm") + ("oddp" "f_evenpc.htm") + ("open" "f_open.htm") + ("open-stream-p" "f_open_s.htm") + ("optimize" "d_optimi.htm") + ("or" "a_or.htm") + ("otherwise" "m_case_.htm") + ("output-stream-p" "f_in_stm.htm") + ("package" "t_pkg.htm") + ("package-error" "e_pkg_er.htm") + ("package-error-package" "f_pkg_er.htm") + ("package-name" "f_pkg_na.htm") + ("package-nicknames" "f_pkg_ni.htm") + ("package-shadowing-symbols" "f_pkg_sh.htm") + ("package-use-list" "f_pkg_us.htm") + ("package-used-by-list" "f_pkg__1.htm") + ("packagep" "f_pkgp.htm") + ("pairlis" "f_pairli.htm") + ("parse-error" "e_parse_.htm") + ("parse-integer" "f_parse_.htm") + ("parse-namestring" "f_pars_1.htm") + ("pathname" "a_pn.htm") + ("pathname-device" "f_pn_hos.htm") + ("pathname-directory" "f_pn_hos.htm") + ("pathname-host" "f_pn_hos.htm") + ("pathname-match-p" "f_pn_mat.htm") + ("pathname-name" "f_pn_hos.htm") + ("pathname-type" "f_pn_hos.htm") + ("pathname-version" "f_pn_hos.htm") + ("pathnamep" "f_pnp.htm") + ("peek-char" "f_peek_c.htm") + ("phase" "f_phase.htm") + ("pi" "v_pi.htm") + ("plusp" "f_minusp.htm") + ("pop" "m_pop.htm") + ("position" "f_pos_p.htm") + ("position-if" "f_pos_p.htm") + ("position-if-not" "f_pos_p.htm") + ("pprint" "f_wr_pr.htm") + ("pprint-dispatch" "f_ppr_di.htm") + ("pprint-exit-if-list-exhausted" "m_ppr_ex.htm") + ("pprint-fill" "f_ppr_fi.htm") + ("pprint-indent" "f_ppr_in.htm") + ("pprint-linear" "f_ppr_fi.htm") + ("pprint-logical-block" "m_ppr_lo.htm") + ("pprint-newline" "f_ppr_nl.htm") + ("pprint-pop" "m_ppr_po.htm") + ("pprint-tab" "f_ppr_ta.htm") + ("pprint-tabular" "f_ppr_fi.htm") + ("prin1" "f_wr_pr.htm") + ("prin1-to-string" "f_wr_to_.htm") + ("princ" "f_wr_pr.htm") + ("princ-to-string" "f_wr_to_.htm") + ("print" "f_wr_pr.htm") + ("print-not-readable" "e_pr_not.htm") + ("print-not-readable-object" "f_pr_not.htm") + ("print-object" "f_pr_obj.htm") + ("print-unreadable-object" "m_pr_unr.htm") + ("probe-file" "f_probe_.htm") + ("proclaim" "f_procla.htm") + ("prog" "m_prog_.htm") + ("prog*" "m_prog_.htm") + ("prog1" "m_prog1c.htm") + ("prog2" "m_prog1c.htm") + ("progn" "s_progn.htm") + ("program-error" "e_progra.htm") + ("progv" "s_progv.htm") + ("provide" "f_provid.htm") + ("psetf" "m_setf_.htm") + ("psetq" "m_psetq.htm") + ("push" "m_push.htm") + ("pushnew" "m_pshnew.htm") + ("quote" "s_quote.htm") + ("random" "f_random.htm") + ("random-state" "t_rnd_st.htm") + ("random-state-p" "f_rnd_st.htm") + ("rassoc" "f_rassoc.htm") + ("rassoc-if" "f_rassoc.htm") + ("rassoc-if-not" "f_rassoc.htm") + ("ratio" "t_ratio.htm") + ("rational" "a_ration.htm") + ("rationalize" "f_ration.htm") + ("rationalp" "f_rati_1.htm") + ("read" "f_rd_rd.htm") + ("read-byte" "f_rd_by.htm") + ("read-char" "f_rd_cha.htm") + ("read-char-no-hang" "f_rd_c_1.htm") + ("read-delimited-list" "f_rd_del.htm") + ("read-from-string" "f_rd_fro.htm") + ("read-line" "f_rd_lin.htm") + ("read-preserving-whitespace" "f_rd_rd.htm") + ("read-sequence" "f_rd_seq.htm") + ("reader-error" "e_rder_e.htm") + ("readtable" "t_rdtabl.htm") + ("readtable-case" "f_rdtabl.htm") + ("readtablep" "f_rdta_1.htm") + ("real" "t_real.htm") + ("realp" "f_realp.htm") + ("realpart" "f_realpa.htm") + ("reduce" "f_reduce.htm") + ("reinitialize-instance" "f_reinit.htm") + ("rem" "f_mod_r.htm") + ("remf" "m_remf.htm") + ("remhash" "f_remhas.htm") + ("remove" "f_rm_rm.htm") + ("remove-duplicates" "f_rm_dup.htm") + ("remove-if" "f_rm_rm.htm") + ("remove-if-not" "f_rm_rm.htm") + ("remove-method" "f_rm_met.htm") + ("remprop" "f_rempro.htm") + ("rename-file" "f_rn_fil.htm") + ("rename-package" "f_rn_pkg.htm") + ("replace" "f_replac.htm") + ("require" "f_provid.htm") + ("rest" "f_rest.htm") + ("restart" "t_rst.htm") + ("restart-bind" "m_rst_bi.htm") + ("restart-case" "m_rst_ca.htm") + ("restart-name" "f_rst_na.htm") + ("return" "m_return.htm") + ("return-from" "s_ret_fr.htm") + ("revappend" "f_revapp.htm") + ("reverse" "f_revers.htm") + ("room" "f_room.htm") + ("rotatef" "m_rotate.htm") + ("round" "f_floorc.htm") + ("row-major-aref" "f_row_ma.htm") + ("rplaca" "f_rplaca.htm") + ("rplacd" "f_rplaca.htm") + ("safety" "d_optimi.htm") + ("satisfies" "t_satisf.htm") + ("sbit" "f_bt_sb.htm") + ("scale-float" "f_dec_fl.htm") + ("schar" "f_char_.htm") + ("search" "f_search.htm") + ("second" "f_firstc.htm") + ("sequence" "t_seq.htm") + ("serious-condition" "e_seriou.htm") + ("set" "f_set.htm") + ("set-difference" "f_set_di.htm") + ("set-dispatch-macro-character" "f_set__1.htm") + ("set-exclusive-or" "f_set_ex.htm") + ("set-macro-character" "f_set_ma.htm") + ("set-pprint-dispatch" "f_set_pp.htm") + ("set-syntax-from-char" "f_set_sy.htm") + ("setf" "a_setf.htm") + ("setq" "s_setq.htm") + ("seventh" "f_firstc.htm") + ("shadow" "f_shadow.htm") + ("shadowing-import" "f_shdw_i.htm") + ("shared-initialize" "f_shared.htm") + ("shiftf" "m_shiftf.htm") + ("short-float" "t_short_.htm") + ("short-float-epsilon" "v_short_.htm") + ("short-float-negative-epsilon" "v_short_.htm") + ("short-site-name" "f_short_.htm") + ("signal" "f_signal.htm") + ("signed-byte" "t_sgn_by.htm") + ("signum" "f_signum.htm") + ("simple-array" "t_smp_ar.htm") + ("simple-base-string" "t_smp_ba.htm") + ("simple-bit-vector" "t_smp_bt.htm") + ("simple-bit-vector-p" "f_smp_bt.htm") + ("simple-condition" "e_smp_cn.htm") + ("simple-condition-format-arguments" "f_smp_cn.htm") + ("simple-condition-format-control" "f_smp_cn.htm") + ("simple-error" "e_smp_er.htm") + ("simple-string" "t_smp_st.htm") + ("simple-string-p" "f_smp_st.htm") + ("simple-type-error" "e_smp_tp.htm") + ("simple-vector" "t_smp_ve.htm") + ("simple-vector-p" "f_smp_ve.htm") + ("simple-warning" "e_smp_wa.htm") + ("sin" "f_sin_c.htm") + ("single-float" "t_short_.htm") + ("single-float-epsilon" "v_short_.htm") + ("single-float-negative-epsilon" "v_short_.htm") + ("sinh" "f_sinh_.htm") + ("sixth" "f_firstc.htm") + ("sleep" "f_sleep.htm") + ("slot-boundp" "f_slt_bo.htm") + ("slot-exists-p" "f_slt_ex.htm") + ("slot-makunbound" "f_slt_ma.htm") + ("slot-missing" "f_slt_mi.htm") + ("slot-unbound" "f_slt_un.htm") + ("slot-value" "f_slt_va.htm") + ("software-type" "f_sw_tpc.htm") + ("software-version" "f_sw_tpc.htm") + ("some" "f_everyc.htm") + ("sort" "f_sort_.htm") + ("space" "d_optimi.htm") + ("special" "d_specia.htm") + ("special-operator-p" "f_specia.htm") + ("speed" "d_optimi.htm") + ("sqrt" "f_sqrt_.htm") + ("stable-sort" "f_sort_.htm") + ("standard" "07_ffb.htm") + ("standard-char" "t_std_ch.htm") + ("standard-char-p" "f_std_ch.htm") + ("standard-class" "t_std_cl.htm") + ("standard-generic-function" "t_std_ge.htm") + ("standard-method" "t_std_me.htm") + ("standard-object" "t_std_ob.htm") + ("step" "m_step.htm") + ("storage-condition" "e_storag.htm") + ("store-value" "a_store_.htm") + ("stream" "t_stream.htm") + ("stream-element-type" "f_stm_el.htm") + ("stream-error" "e_stm_er.htm") + ("stream-error-stream" "f_stm_er.htm") + ("stream-external-format" "f_stm_ex.htm") + ("streamp" "f_stmp.htm") + ("string" "a_string.htm") + ("string-capitalize" "f_stg_up.htm") + ("string-downcase" "f_stg_up.htm") + ("string-equal" "f_stgeq_.htm") + ("string-greaterp" "f_stgeq_.htm") + ("string-left-trim" "f_stg_tr.htm") + ("string-lessp" "f_stgeq_.htm") + ("string-not-equal" "f_stgeq_.htm") + ("string-not-greaterp" "f_stgeq_.htm") + ("string-not-lessp" "f_stgeq_.htm") + ("string-right-trim" "f_stg_tr.htm") + ("string-stream" "t_stg_st.htm") + ("string-trim" "f_stg_tr.htm") + ("string-upcase" "f_stg_up.htm") + ("string/=" "f_stgeq_.htm") + ("string<" "f_stgeq_.htm") + ("string<=" "f_stgeq_.htm") + ("string=" "f_stgeq_.htm") + ("string>" "f_stgeq_.htm") + ("string>=" "f_stgeq_.htm") + ("stringp" "f_stgp.htm") + ("structure" "f_docume.htm") + ("structure-class" "t_stu_cl.htm") + ("structure-object" "t_stu_ob.htm") + ("style-warning" "e_style_.htm") + ("sublis" "f_sublis.htm") + ("subseq" "f_subseq.htm") + ("subsetp" "f_subset.htm") + ("subst" "f_substc.htm") + ("subst-if" "f_substc.htm") + ("subst-if-not" "f_substc.htm") + ("substitute" "f_sbs_s.htm") + ("substitute-if" "f_sbs_s.htm") + ("substitute-if-not" "f_sbs_s.htm") + ("subtypep" "f_subtpp.htm") + ("svref" "f_svref.htm") + ("sxhash" "f_sxhash.htm") + ("symbol" "t_symbol.htm") + ("symbol-function" "f_symb_1.htm") + ("symbol-macrolet" "s_symbol.htm") + ("symbol-name" "f_symb_2.htm") + ("symbol-package" "f_symb_3.htm") + ("symbol-plist" "f_symb_4.htm") + ("symbol-value" "f_symb_5.htm") + ("symbolp" "f_symbol.htm") + ("synonym-stream" "t_syn_st.htm") + ("synonym-stream-symbol" "f_syn_st.htm") + ("t" "a_t.htm") + ("tagbody" "s_tagbod.htm") + ("tailp" "f_ldiffc.htm") + ("tan" "f_sin_c.htm") + ("tanh" "f_sinh_.htm") + ("tenth" "f_firstc.htm") + ("terpri" "f_terpri.htm") + ("the" "s_the.htm") + ("third" "f_firstc.htm") + ("throw" "s_throw.htm") + ("time" "m_time.htm") + ("trace" "m_tracec.htm") + ("translate-logical-pathname" "f_tr_log.htm") + ("translate-pathname" "f_tr_pn.htm") + ("tree-equal" "f_tree_e.htm") + ("truename" "f_tn.htm") + ("truncate" "f_floorc.htm") + ("two-way-stream" "t_two_wa.htm") + ("two-way-stream-input-stream" "f_two_wa.htm") + ("two-way-stream-output-stream" "f_two_wa.htm") + ("type" "a_type.htm") + ("type-error" "e_tp_err.htm") + ("type-error-datum" "f_tp_err.htm") + ("type-error-expected-type" "f_tp_err.htm") + ("type-of" "f_tp_of.htm") + ("typecase" "m_tpcase.htm") + ("typep" "f_typep.htm") + ("unbound-slot" "e_unboun.htm") + ("unbound-slot-instance" "f_unboun.htm") + ("unbound-variable" "e_unbo_1.htm") + ("undefined-function" "e_undefi.htm") + ("unexport" "f_unexpo.htm") + ("unintern" "f_uninte.htm") + ("union" "f_unionc.htm") + ("unless" "m_when_.htm") + ("unread-char" "f_unrd_c.htm") + ("unsigned-byte" "t_unsgn_.htm") + ("untrace" "m_tracec.htm") + ("unuse-package" "f_unuse_.htm") + ("unwind-protect" "s_unwind.htm") + ("update-instance-for-different-class" "f_update.htm") + ("update-instance-for-redefined-class" "f_upda_1.htm") + ("upgraded-array-element-type" "f_upgr_1.htm") + ("upgraded-complex-part-type" "f_upgrad.htm") + ("upper-case-p" "f_upper_.htm") + ("use-package" "f_use_pk.htm") + ("use-value" "a_use_va.htm") + ("user-homedir-pathname" "f_user_h.htm") + ("values" "a_values.htm") + ("values-list" "f_vals_l.htm") + ("variable" "f_docume.htm") + ("vector" "a_vector.htm") + ("vector-pop" "f_vec_po.htm") + ("vector-push" "f_vec_ps.htm") + ("vector-push-extend" "f_vec_ps.htm") + ("vectorp" "f_vecp.htm") + ("warn" "f_warn.htm") + ("warning" "e_warnin.htm") + ("when" "m_when_.htm") + ("wild-pathname-p" "f_wild_p.htm") + ("with-accessors" "m_w_acce.htm") + ("with-compilation-unit" "m_w_comp.htm") + ("with-condition-restarts" "m_w_cnd_.htm") + ("with-hash-table-iterator" "m_w_hash.htm") + ("with-input-from-string" "m_w_in_f.htm") + ("with-open-file" "m_w_open.htm") + ("with-open-stream" "m_w_op_1.htm") + ("with-output-to-string" "m_w_out_.htm") + ("with-package-iterator" "m_w_pkg_.htm") + ("with-simple-restart" "m_w_smp_.htm") + ("with-slots" "m_w_slts.htm") + ("with-standard-io-syntax" "m_w_std_.htm") + ("write" "f_wr_pr.htm") + ("write-byte" "f_wr_by.htm") + ("write-char" "f_wr_cha.htm") + ("write-line" "f_wr_stg.htm") + ("write-sequence" "f_wr_seq.htm") + ("write-string" "f_wr_stg.htm") + ("write-to-string" "f_wr_to_.htm") + ("y-or-n-p" "f_y_or_n.htm") + ("yes-or-no-p" "f_y_or_n.htm") + ("zerop" "f_zerop.htm")))) + +;;; Added entries for reader macros. +;;; +;;; 20090302 Tobias C Rittweiler, and Stas Boukarev + +(defvar common-lisp-hyperspec--reader-macros (make-hash-table :test #'equal)) + +;;; Data/Map_Sym.txt in does not contain entries for the reader +;;; macros. So we have to enumerate these explicitly. +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--reader-macros)) + '(("#" "02_dh.htm") + ("##" "02_dhp.htm") + ("#'" "02_dhb.htm") + ("#(" "02_dhc.htm") + ("#*" "02_dhd.htm") + ("#:" "02_dhe.htm") + ("#." "02_dhf.htm") + ("#=" "02_dho.htm") + ("#+" "02_dhq.htm") + ("#-" "02_dhr.htm") + ("#<" "02_dht.htm") + ("#A" "02_dhl.htm") + ("#B" "02_dhg.htm") + ("#C" "02_dhk.htm") + ("#O" "02_dhh.htm") + ("#P" "02_dhn.htm") + ("#R" "02_dhj.htm") + ("#S" "02_dhm.htm") + ("#X" "02_dhi.htm") + ("#\\" "02_dha.htm") + ("#|" "02_dhs.htm") + ("\"" "02_de.htm") + ("'" "02_dc.htm") + ("`" "02_df.htm") + ("," "02_dg.htm") + ("(" "02_da.htm") + (")" "02_db.htm") + (";" "02_dd.htm"))) + +(defun common-lisp-hyperspec-lookup-reader-macro (macro) + "Browse the CLHS entry for the reader-macro MACRO." + (interactive + (list + (let ((completion-ignore-case t)) + (completing-read "Look up reader-macro: " + common-lisp-hyperspec--reader-macros nil t + (common-lisp-hyperspec-reader-macro-at-point))))) + (browse-url + (concat common-lisp-hyperspec-root "Body/" + (gethash macro common-lisp-hyperspec--reader-macros)))) + +(defun common-lisp-hyperspec-reader-macro-at-point () + (let ((regexp "\\(#.?\\)\\|\\([\"',`';()]\\)")) + (when (looking-back regexp nil t) + (match-string-no-properties 0)))) + +;;; FORMAT character lookup by Frode Vatvedt Fjeld 20030902 +;;; +;;; adjusted for ILISP by Nikodemus Siivola 20030903 + +(defvar common-lisp-hyperspec-format-history nil + "History of format characters looked up in the Common Lisp HyperSpec.") + +(defun common-lisp-hyperspec-section-6.0 (indices) + (let ((string (format "%sBody/%s_" + common-lisp-hyperspec-root + (let ((base (pop indices))) + (if (< base 10) + (format "0%s" base) + base))))) + (concat string + (mapconcat (lambda (n) + (make-string 1 (+ ?a (- n 1)))) + indices + "") + ".htm"))) + +(defun common-lisp-hyperspec-section-4.0 (indices) + (let ((string (format "%sBody/sec_" + common-lisp-hyperspec-root))) + (concat string + (mapconcat (lambda (n) + (format "%d" n)) + indices + "-") + ".html"))) + +(defvar common-lisp-hyperspec-section-fun 'common-lisp-hyperspec-section-6.0) + +(defun common-lisp-hyperspec-section (indices) + (funcall common-lisp-hyperspec-section-fun indices)) + +(defvar common-lisp-hyperspec--format-characters + (make-hash-table :test 'equal)) + +(defun common-lisp-hyperspec--read-format-character () + (let ((char-at-point + (ignore-errors (char-to-string (char-after (point)))))) + (if (and char-at-point + (gethash (upcase char-at-point) + common-lisp-hyperspec--format-characters)) + char-at-point + (completing-read + "Look up format control character in Common Lisp HyperSpec: " + common-lisp-hyperspec--format-characters nil t nil + 'common-lisp-hyperspec-format-history)))) + +(defun common-lisp-hyperspec-format (character-name) + (interactive (list (common-lisp-hyperspec--read-format-character))) + (cl-maplist (lambda (entry) + (browse-url (common-lisp-hyperspec-section (car entry)))) + (or (gethash character-name + common-lisp-hyperspec--format-characters) + (error "The symbol `%s' is not defined in Common Lisp" + character-name)))) + +;;; Previously there were entries for "C" and "C: Character", +;;; which unpleasingly crowded the completion buffer, so I made +;;; it show one entry ("C - Character") only. +;;; +;;; 20100131 Tobias C Rittweiler + +(defun common-lisp-hyperspec--insert-format-directive (char section + &optional summary) + (let* ((designator (if summary (format "%s - %s" char summary) char))) + (cl-pushnew section (gethash designator + common-lisp-hyperspec--format-characters) + :test #'equal))) + +(mapc (lambda (entry) + (cl-destructuring-bind (char section &optional summary) entry + (common-lisp-hyperspec--insert-format-directive char section summary) + (when (and (= 1 (length char)) + (not (string-equal char (upcase char)))) + (common-lisp-hyperspec--insert-format-directive + (upcase char) section summary)))) + '(("c" (22 3 1 1) "Character") + ("%" (22 3 1 2) "Newline") + ("&" (22 3 1 3) "Fresh-line") + ("|" (22 3 1 4) "Page") + ("~" (22 3 1 5) "Tilde") + ("r" (22 3 2 1) "Radix") + ("d" (22 3 2 2) "Decimal") + ("b" (22 3 2 3) "Binary") + ("o" (22 3 2 4) "Octal") + ("x" (22 3 2 5) "Hexadecimal") + ("f" (22 3 3 1) "Fixed-Format Floating-Point") + ("e" (22 3 3 2) "Exponential Floating-Point") + ("g" (22 3 3 3) "General Floating-Point") + ("$" (22 3 3 4) "Monetary Floating-Point") + ("a" (22 3 4 1) "Aesthetic") + ("s" (22 3 4 2) "Standard") + ("w" (22 3 4 3) "Write") + ("_" (22 3 5 1) "Conditional Newline") + ("<" (22 3 5 2) "Logical Block") + ("i" (22 3 5 3) "Indent") + ("/" (22 3 5 4) "Call Function") + ("t" (22 3 6 1) "Tabulate") + ("<" (22 3 6 2) "Justification") + (">" (22 3 6 3) "End of Justification") + ("*" (22 3 7 1) "Go-To") + ("[" (22 3 7 2) "Conditional Expression") + ("]" (22 3 7 3) "End of Conditional Expression") + ("{" (22 3 7 4) "Iteration") + ("}" (22 3 7 5) "End of Iteration") + ("?" (22 3 7 6) "Recursive Processing") + ("(" (22 3 8 1) "Case Conversion") + (")" (22 3 8 2) "End of Case Conversion") + ("p" (22 3 8 3) "Plural") + (";" (22 3 9 1) "Clause Separator") + ("^" (22 3 9 2) "Escape Upward") + ("Newline: Ignored Newline" (22 3 9 3)) + ("Nesting of FORMAT Operations" (22 3 10 1)) + ("Missing and Additional FORMAT Arguments" (22 3 10 2)) + ("Additional FORMAT Parameters" (22 3 10 3)))) + + +;;;; Glossary + +(defvar common-lisp-hyperspec-glossary-function 'common-lisp-glossary-6.0 + "Function that creates a URL for a glossary term.") + +(define-obsolete-variable-alias 'common-lisp-glossary-fun + 'common-lisp-hyperspec-glossary-function "Dec 2015") + +(defvar common-lisp-hyperspec--glossary-terms (make-hash-table :test #'equal) + "Collection of glossary terms and relative URLs.") + +;;; Functions + +;;; The functions below are used to collect glossary terms and page anchors +;;; from CLHS. They are commented out because they are not needed unless the +;;; list of terms/anchors need to be updated. + +;; (defun common-lisp-hyperspec-glossary-pages () +;; "List of CLHS glossary pages." +;; (mapcar (lambda (end) +;; (format "%sBody/26_glo_%s.htm" +;; common-lisp-hyperspec-root +;; end)) +;; (cons "9" (mapcar #'char-to-string +;; (number-sequence ?a ?z))))) + +;; (defun common-lisp-hyperspec-glossary-download () +;; "Download CLHS glossary pages to temporary files and return a +;; list of file names." +;; (mapcar (lambda (url) +;; (url-file-local-copy url)) +;; (common-lisp-hyperspec-glossary-pages))) + +;; (defun common-lisp-hyperspec-glossary-entries (file) +;; "Given a CLHS glossary file FILE, return a list of +;; term-anchor pairs. + +;; Term is the glossary term and anchor is the term's anchor on the +;; page." +;; (let (entries) +;; (save-excursion +;; (set-buffer (find-file-noselect file)) +;; (goto-char (point-min)) +;; (while (search-forward-regexp "\\(.*?\\)" nil t) +;; (setq entries (cons (list (match-string-no-properties 2) +;; (match-string-no-properties 1)) +;; entries)))) +;; (sort entries (lambda (a b) +;; (string< (car a) (car b)))))) + +;; ;; Add glossary terms by downloading and parsing glossary pages from CLHS +;; (mapc (lambda (entry) +;; (puthash (car entry) (cadr entry) +;; common-lisp-hyperspec--glossary-terms)) +;; (cl-reduce (lambda (a b) +;; (append a b)) +;; (mapcar #'common-lisp-hyperspec-glossary-entries +;; (common-lisp-hyperspec-glossary-download)))) + +;; Add glossary entries to the master hash table +(mapc (lambda (entry) + (puthash (car entry) (cadr entry) + common-lisp-hyperspec--glossary-terms)) + '(("()" "OPCP") + ("absolute" "absolute") + ("access" "access") + ("accessibility" "accessibility") + ("accessible" "accessible") + ("accessor" "accessor") + ("active" "active") + ("actual adjustability" "actual_adjustability") + ("actual argument" "actual_argument") + ("actual array element type" "actual_array_element_type") + ("actual complex part type" "actual_complex_part_type") + ("actual parameter" "actual_parameter") + ("actually adjustable" "actually_adjustable") + ("adjustability" "adjustability") + ("adjustable" "adjustable") + ("after method" "after_method") + ("alist" "alist") + ("alphabetic" "alphabetic") + ("alphanumeric" "alphanumeric") + ("ampersand" "ampersand") + ("anonymous" "anonymous") + ("apparently uninterned" "apparently_uninterned") + ("applicable" "applicable") + ("applicable handler" "applicable_handler") + ("applicable method" "applicable_method") + ("applicable restart" "applicable_restart") + ("apply" "apply") + ("argument" "argument") + ("argument evaluation order" "argument_evaluation_order") + ("argument precedence order" "argument_precedence_order") + ("around method" "around_method") + ("array" "array") + ("array element type" "array_element_type") + ("array total size" "array_total_size") + ("assign" "assign") + ("association list" "association_list") + ("asterisk" "asterisk") + ("at-sign" "at-sign") + ("atom" "atom") + ("atomic" "atomic") + ("atomic type specifier" "atomic_type_specifier") + ("attribute" "attribute") + ("aux variable" "aux_variable") + ("auxiliary method" "auxiliary_method") + ("backquote" "backquote") + ("backslash" "backslash") + ("base character" "base_character") + ("base string" "base_string") + ("before method" "before_method") + ("bidirectional" "bidirectional") + ("binary" "binary") + ("bind" "bind") + ("binding" "binding") + ("bit" "bit") + ("bit array" "bit_array") + ("bit vector" "bit_vector") + ("bit-wise logical operation specifier" "bit-wise_logical_operation_specifier") + ("block" "block") + ("block tag" "block_tag") + ("boa lambda list" "boa_lambda_list") + ("body parameter" "body_parameter") + ("boolean" "boolean") + ("boolean equivalent" "boolean_equivalent") + ("bound" "bound") + ("bound declaration" "bound_declaration") + ("bounded" "bounded") + ("bounding index" "bounding_index") + ("bounding index designator" "bounding_index_designator") + ("break loop" "break_loop") + ("broadcast stream" "broadcast_stream") + ("built-in class" "built-in_class") + ("built-in type" "built-in_type") + ("byte" "byte") + ("byte specifier" "byte_specifier") + ("cadr" "cadr") + ("call" "call") + ("captured initialization form" "captured_initialization_form") + ("car" "car") + ("case" "case") + ("case sensitivity mode" "case_sensitivity_mode") + ("catch" "catch") + ("catch tag" "catch_tag") + ("cddr" "cddr") + ("cdr" "cdr") + ("cell" "cell") + ("character" "character") + ("character code" "character_code") + ("character designator" "character_designator") + ("circular" "circular") + ("circular list" "circular_list") + ("class" "class") + ("class designator" "class_designator") + ("class precedence list" "class_precedence_list") + ("close" "close") + ("closed" "closed") + ("closure" "closure") + ("coalesce" "coalesce") + ("code" "code") + ("coerce" "coerce") + ("colon" "colon") + ("comma" "comma") + ("compilation" "compilation") + ("compilation environment" "compilation_environment") + ("compilation unit" "compilation_unit") + ("compile" "compile") + ("compile time" "compile_time") + ("compile-time definition" "compile-time_definition") + ("compiled code" "compiled_code") + ("compiled file" "compiled_file") + ("compiled function" "compiled_function") + ("compiler" "compiler") + ("compiler macro" "compiler_macro") + ("compiler macro expansion" "compiler_macro_expansion") + ("compiler macro form" "compiler_macro_form") + ("compiler macro function" "compiler_macro_function") + ("complex" "complex") + ("complex float" "complex_float") + ("complex part type" "complex_part_type") + ("complex rational" "complex_rational") + ("complex single float" "complex_single_float") + ("composite stream" "composite_stream") + ("compound form" "compound_form") + ("compound type specifier" "compound_type_specifier") + ("concatenated stream" "concatenated_stream") + ("condition" "condition") + ("condition designator" "condition_designator") + ("condition handler" "condition_handler") + ("condition reporter" "condition_reporter") + ("conditional newline" "conditional_newline") + ("conformance" "conformance") + ("conforming code" "conforming_code") + ("conforming implementation" "conforming_implementation") + ("conforming processor" "conforming_processor") + ("conforming program" "conforming_program") + ("congruent" "congruent") + ("cons" "cons") + ("constant" "constant") + ("constant form" "constant_form") + ("constant object" "constant_object") + ("constant variable" "constant_variable") + ("constituent" "constituent") + ("constituent trait" "constituent_trait") + ("constructed stream" "constructed_stream") + ("contagion" "contagion") + ("continuable" "continuable") + ("control form" "control_form") + ("copy" "copy") + ("correctable" "correctable") + ("current input base" "current_input_base") + ("current logical block" "current_logical_block") + ("current output base" "current_output_base") + ("current package" "current_package") + ("current pprint dispatch table" "current_pprint_dispatch_table") + ("current random state" "current_random_state") + ("current readtable" "current_readtable") + ("data type" "data_type") + ("debug I/O" "debug_iSLo") + ("debugger" "debugger") + ("declaration" "declaration") + ("declaration identifier" "declaration_identifier") + ("declaration specifier" "declaration_specifier") + ("declare" "declare") + ("decline" "decline") + ("decoded time" "decoded_time") + ("default method" "default_method") + ("defaulted initialization argument list" "defaulted_initialization_argument_list") + ("define-method-combination arguments lambda list" "define-method-combination_arguments_lambda_list") + ("define-modify-macro lambda list" "define-modify-macro_lambda_list") + ("defined name" "defined_name") + ("defining form" "defining_form") + ("defsetf lambda list" "defsetf_lambda_list") + ("deftype lambda list" "deftype_lambda_list") + ("denormalized" "denormalized") + ("derived type" "derived_type") + ("derived type specifier" "derived_type_specifier") + ("designator" "designator") + ("destructive" "destructive") + ("destructuring lambda list" "destructuring_lambda_list") + ("different" "different") + ("digit" "digit") + ("dimension" "dimension") + ("direct instance" "direct_instance") + ("direct subclass" "direct_subclass") + ("direct superclass" "direct_superclass") + ("disestablish" "disestablish") + ("disjoint" "disjoint") + ("dispatching macro character" "dispatching_macro_character") + ("displaced array" "displaced_array") + ("distinct" "distinct") + ("documentation string" "documentation_string") + ("dot" "dot") + ("dotted list" "dotted_list") + ("dotted pair" "dotted_pair") + ("double float" "double_float") + ("double-quote" "double-quote") + ("dynamic binding" "dynamic_binding") + ("dynamic environment" "dynamic_environment") + ("dynamic extent" "dynamic_extent") + ("dynamic scope" "dynamic_scope") + ("dynamic variable" "dynamic_variable") + ("echo stream" "echo_stream") + ("effective method" "effective_method") + ("element" "element") + ("element type" "element_type") + ("em" "em") + ("empty list" "empty_list") + ("empty type" "empty_type") + ("end of file" "end_of_file") + ("environment" "environment") + ("environment object" "environment_object") + ("environment parameter" "environment_parameter") + ("error" "error") + ("error output" "error_output") + ("escape" "escape") + ("establish" "establish") + ("evaluate" "evaluate") + ("evaluation" "evaluation") + ("evaluation environment" "evaluation_environment") + ("execute" "execute") + ("execution time" "execution_time") + ("exhaustive partition" "exhaustive_partition") + ("exhaustive union" "exhaustive_union") + ("exit point" "exit_point") + ("explicit return" "explicit_return") + ("explicit use" "explicit_use") + ("exponent marker" "exponent_marker") + ("export" "export") + ("exported" "exported") + ("expressed adjustability" "expressed_adjustability") + ("expressed array element type" "expressed_array_element_type") + ("expressed complex part type" "expressed_complex_part_type") + ("expression" "expression") + ("expressly adjustable" "expressly_adjustable") + ("extended character" "extended_character") + ("extended function designator" "extended_function_designator") + ("extended lambda list" "extended_lambda_list") + ("extension" "extension") + ("extent" "extent") + ("external file format" "external_file_format") + ("external file format designator" "external_file_format_designator") + ("external symbol" "external_symbol") + ("externalizable object" "externalizable_object") + ("false" "false") + ("fbound" "fbound") + ("feature" "feature") + ("feature expression" "feature_expression") + ("features list" "features_list") + ("file" "file") + ("file compiler" "file_compiler") + ("file position" "file_position") + ("file position designator" "file_position_designator") + ("file stream" "file_stream") + ("file system" "file_system") + ("filename" "filename") + ("fill pointer" "fill_pointer") + ("finite" "finite") + ("fixnum" "fixnum") + ("float" "float") + ("for-value" "for-value") + ("form" "form") + ("formal argument" "formal_argument") + ("formal parameter" "formal_parameter") + ("format" "format") + ("format argument" "format_argument") + ("format control" "format_control") + ("format directive" "format_directive") + ("format string" "format_string") + ("free declaration" "free_declaration") + ("fresh" "fresh") + ("freshline" "freshline") + ("funbound" "funbound") + ("function" "function") + ("function block name" "function_block_name") + ("function cell" "function_cell") + ("function designator" "function_designator") + ("function form" "function_form") + ("function name" "function_name") + ("functional evaluation" "functional_evaluation") + ("functional value" "functional_value") + ("further compilation" "further_compilation") + ("general" "general") + ("generalized boolean" "generalized_boolean") + ("generalized instance" "generalized_instance") + ("generalized reference" "generalized_reference") + ("generalized synonym stream" "generalized_synonym_stream") + ("generic function" "generic_function") + ("generic function lambda list" "generic_function_lambda_list") + ("gensym" "gensym") + ("global declaration" "global_declaration") + ("global environment" "global_environment") + ("global variable" "global_variable") + ("glyph" "glyph") + ("go" "go") + ("go point" "go_point") + ("go tag" "go_tag") + ("graphic" "graphic") + ("handle" "handle") + ("handler" "handler") + ("hash table" "hash_table") + ("home package" "home_package") + ("I/O customization variable" "iSLo_customization_variable") + ("identical" "identical") + ("identifier" "identifier") + ("immutable" "immutable") + ("implementation" "implementation") + ("implementation limit" "implementation_limit") + ("implementation-defined" "implementation-defined") + ("implementation-dependent" "implementation-dependent") + ("implementation-independent" "implementation-independent") + ("implicit block" "implicit_block") + ("implicit compilation" "implicit_compilation") + ("implicit progn" "implicit_progn") + ("implicit tagbody" "implicit_tagbody") + ("import" "import") + ("improper list" "improper_list") + ("inaccessible" "inaccessible") + ("indefinite extent" "indefinite_extent") + ("indefinite scope" "indefinite_scope") + ("indicator" "indicator") + ("indirect instance" "indirect_instance") + ("inherit" "inherit") + ("initial pprint dispatch table" "initial_pprint_dispatch_table") + ("initial readtable" "initial_readtable") + ("initialization argument list" "initialization_argument_list") + ("initialization form" "initialization_form") + ("input" "input") + ("instance" "instance") + ("integer" "integer") + ("interactive stream" "interactive_stream") + ("intern" "intern") + ("internal symbol" "internal_symbol") + ("internal time" "internal_time") + ("internal time unit" "internal_time_unit") + ("interned" "interned") + ("interpreted function" "interpreted_function") + ("interpreted implementation" "interpreted_implementation") + ("interval designator" "interval_designator") + ("invalid" "invalid") + ("iteration form" "iteration_form") + ("iteration variable" "iteration_variable") + ("key" "key") + ("keyword" "keyword") + ("keyword parameter" "keyword_parameter") + ("keyword/value pair" "keywordSLvalue_pair") + ("Lisp image" "lisp_image") + ("Lisp printer" "lisp_printer") + ("Lisp read-eval-print loop" "lisp_read-eval-print_loop") + ("Lisp reader" "lisp_reader") + ("lambda combination" "lambda_combination") + ("lambda expression" "lambda_expression") + ("lambda form" "lambda_form") + ("lambda list" "lambda_list") + ("lambda list keyword" "lambda_list_keyword") + ("lambda variable" "lambda_variable") + ("leaf" "leaf") + ("leap seconds" "leap_seconds") + ("left-parenthesis" "left-parenthesis") + ("length" "length") + ("lexical binding" "lexical_binding") + ("lexical closure" "lexical_closure") + ("lexical environment" "lexical_environment") + ("lexical scope" "lexical_scope") + ("lexical variable" "lexical_variable") + ("list" "list") + ("list designator" "list_designator") + ("list structure" "list_structure") + ("literal" "literal") + ("load" "load") + ("load time" "load_time") + ("load time value" "load_time_value") + ("loader" "loader") + ("local declaration" "local_declaration") + ("local precedence order" "local_precedence_order") + ("local slot" "local_slot") + ("logical block" "logical_block") + ("logical host" "logical_host") + ("logical host designator" "logical_host_designator") + ("logical pathname" "logical_pathname") + ("long float" "long_float") + ("loop keyword" "loop_keyword") + ("lowercase" "lowercase") + ("Metaobject Protocol" "metaobject_protocol") + ("macro" "macro") + ("macro character" "macro_character") + ("macro expansion" "macro_expansion") + ("macro form" "macro_form") + ("macro function" "macro_function") + ("macro lambda list" "macro_lambda_list") + ("macro name" "macro_name") + ("macroexpand hook" "macroexpand_hook") + ("mapping" "mapping") + ("metaclass" "metaclass") + ("method" "method") + ("method combination" "method_combination") + ("method-defining form" "method-defining_form") + ("method-defining operator" "method-defining_operator") + ("minimal compilation" "minimal_compilation") + ("modified lambda list" "modified_lambda_list") + ("most recent" "most_recent") + ("multiple escape" "multiple_escape") + ("multiple values" "multiple_values") + ("name" "name") + ("named constant" "named_constant") + ("namespace" "namespace") + ("namestring" "namestring") + ("newline" "newline") + ("next method" "next_method") + ("nickname" "nickname") + ("nil" "nil") + ("non-atomic" "non-atomic") + ("non-constant variable" "non-constant_variable") + ("non-correctable" "non-correctable") + ("non-empty" "non-empty") + ("non-generic function" "non-generic_function") + ("non-graphic" "non-graphic") + ("non-list" "non-list") + ("non-local exit" "non-local_exit") + ("non-nil" "non-nil") + ("non-null lexical environment" "non-null_lexical_environment") + ("non-simple" "non-simple") + ("non-terminating" "non-terminating") + ("non-top-level form" "non-top-level_form") + ("normal return" "normal_return") + ("normalized" "normalized") + ("null" "null") + ("null lexical environment" "null_lexical_environment") + ("number" "number") + ("numeric" "numeric") + ("object" "object") + ("object-traversing" "object-traversing") + ("open" "open") + ("operator" "operator") + ("optimize quality" "optimize_quality") + ("optional parameter" "optional_parameter") + ("ordinary function" "ordinary_function") + ("ordinary lambda list" "ordinary_lambda_list") + ("otherwise inaccessible part" "otherwise_inaccessible_part") + ("output" "output") + ("package" "package") + ("package cell" "package_cell") + ("package designator" "package_designator") + ("package marker" "package_marker") + ("package prefix" "package_prefix") + ("package registry" "package_registry") + ("pairwise" "pairwise") + ("parallel" "parallel") + ("parameter" "parameter") + ("parameter specializer" "parameter_specializer") + ("parameter specializer name" "parameter_specializer_name") + ("pathname" "pathname") + ("pathname designator" "pathname_designator") + ("physical pathname" "physical_pathname") + ("place" "place") + ("plist" "plist") + ("portable" "portable") + ("potential copy" "potential_copy") + ("potential number" "potential_number") + ("pprint dispatch table" "pprint_dispatch_table") + ("predicate" "predicate") + ("present" "present") + ("pretty print" "pretty_print") + ("pretty printer" "pretty_printer") + ("pretty printing stream" "pretty_printing_stream") + ("primary method" "primary_method") + ("primary value" "primary_value") + ("principal" "principal") + ("print name" "print_name") + ("printer control variable" "printer_control_variable") + ("printer escaping" "printer_escaping") + ("printing" "printing") + ("process" "process") + ("processor" "processor") + ("proclaim" "proclaim") + ("proclamation" "proclamation") + ("prog tag" "prog_tag") + ("program" "program") + ("programmer" "programmer") + ("programmer code" "programmer_code") + ("proper list" "proper_list") + ("proper name" "proper_name") + ("proper sequence" "proper_sequence") + ("proper subtype" "proper_subtype") + ("property" "property") + ("property indicator" "property_indicator") + ("property list" "property_list") + ("property value" "property_value") + ("purports to conform" "purports_to_conform") + ("qualified method" "qualified_method") + ("qualifier" "qualifier") + ("query I/O" "query_iSLo") + ("quoted object" "quoted_object") + ("radix" "radix") + ("random state" "random_state") + ("rank" "rank") + ("ratio" "ratio") + ("ratio marker" "ratio_marker") + ("rational" "rational") + ("read" "read") + ("readably" "readably") + ("reader" "reader") + ("reader macro" "reader_macro") + ("reader macro function" "reader_macro_function") + ("readtable" "readtable") + ("readtable case" "readtable_case") + ("readtable designator" "readtable_designator") + ("recognizable subtype" "recognizable_subtype") + ("reference" "reference") + ("registered package" "registered_package") + ("relative" "relative") + ("repertoire" "repertoire") + ("report" "report") + ("report message" "report_message") + ("required parameter" "required_parameter") + ("rest list" "rest_list") + ("rest parameter" "rest_parameter") + ("restart" "restart") + ("restart designator" "restart_designator") + ("restart function" "restart_function") + ("return" "return") + ("return value" "return_value") + ("right-parenthesis" "right-parenthesis") + ("run time" "run_time") + ("run-time compiler" "run-time_compiler") + ("run-time definition" "run-time_definition") + ("run-time environment" "run-time_environment") + ("safe" "safe") + ("safe call" "safe_call") + ("same" "same") + ("satisfy the test" "satisfy_the_test") + ("scope" "scope") + ("script" "script") + ("secondary value" "secondary_value") + ("section" "section") + ("self-evaluating object" "self-evaluating_object") + ("semi-standard" "semi-standard") + ("semicolon" "semicolon") + ("sequence" "sequence") + ("sequence function" "sequence_function") + ("sequential" "sequential") + ("sequentially" "sequentially") + ("serious condition" "serious_condition") + ("session" "session") + ("set" "set") + ("setf expander" "setf_expander") + ("setf expansion" "setf_expansion") + ("setf function" "setf_function") + ("setf function name" "setf_function_name") + ("shadow" "shadow") + ("shadowing symbol" "shadowing_symbol") + ("shadowing symbols list" "shadowing_symbols_list") + ("shared slot" "shared_slot") + ("sharpsign" "sharpsign") + ("short float" "short_float") + ("sign" "sign") + ("signal" "signal") + ("signature" "signature") + ("similar" "similar") + ("similarity" "similarity") + ("simple" "simple") + ("simple array" "simple_array") + ("simple bit array" "simple_bit_array") + ("simple bit vector" "simple_bit_vector") + ("simple condition" "simple_condition") + ("simple general vector" "simple_general_vector") + ("simple string" "simple_string") + ("simple vector" "simple_vector") + ("single escape" "single_escape") + ("single float" "single_float") + ("single-quote" "single-quote") + ("singleton" "singleton") + ("situation" "situation") + ("slash" "slash") + ("slot" "slot") + ("slot specifier" "slot_specifier") + ("source code" "source_code") + ("source file" "source_file") + ("space" "space") + ("special form" "special_form") + ("special operator" "special_operator") + ("special variable" "special_variable") + ("specialize" "specialize") + ("specialized" "specialized") + ("specialized lambda list" "specialized_lambda_list") + ("spreadable argument list designator" "spreadable_argument_list_designator") + ("stack allocate" "stack_allocate") + ("stack-allocated" "stack-allocated") + ("standard character" "standard_character") + ("standard class" "standard_class") + ("standard generic function" "standard_generic_function") + ("standard input" "standard_input") + ("standard method combination" "standard_method_combination") + ("standard object" "standard_object") + ("standard output" "standard_output") + ("standard pprint dispatch table" "standard_pprint_dispatch_table") + ("standard readtable" "standard_readtable") + ("standard syntax" "standard_syntax") + ("standardized" "standardized") + ("startup environment" "startup_environment") + ("step" "step") + ("stream" "stream") + ("stream associated with a file" "stream_associated_with_a_file") + ("stream designator" "stream_designator") + ("stream element type" "stream_element_type") + ("stream variable" "stream_variable") + ("stream variable designator" "stream_variable_designator") + ("string" "string") + ("string designator" "string_designator") + ("string equal" "string_equal") + ("string stream" "string_stream") + ("structure" "structure") + ("structure class" "structure_class") + ("structure name" "structure_name") + ("style warning" "style_warning") + ("subclass" "subclass") + ("subexpression" "subexpression") + ("subform" "subform") + ("subrepertoire" "subrepertoire") + ("subtype" "subtype") + ("superclass" "superclass") + ("supertype" "supertype") + ("supplied-p parameter" "supplied-p_parameter") + ("symbol" "symbol") + ("symbol macro" "symbol_macro") + ("synonym stream" "synonym_stream") + ("synonym stream symbol" "synonym_stream_symbol") + ("syntax type" "syntax_type") + ("system class" "system_class") + ("system code" "system_code") + ("t" "t") + ("tag" "tag") + ("tail" "tail") + ("target" "target") + ("terminal I/O" "terminal_iSLo") + ("terminating" "terminating") + ("tertiary value" "tertiary_value") + ("throw" "throw") + ("tilde" "tilde") + ("time" "time") + ("time zone" "time_zone") + ("token" "token") + ("top level form" "top_level_form") + ("trace output" "trace_output") + ("tree" "tree") + ("tree structure" "tree_structure") + ("true" "true") + ("truename" "truename") + ("two-way stream" "two-way_stream") + ("type" "type") + ("type declaration" "type_declaration") + ("type equivalent" "type_equivalent") + ("type expand" "type_expand") + ("type specifier" "type_specifier") + ("unbound" "unbound") + ("unbound variable" "unbound_variable") + ("undefined function" "undefined_function") + ("unintern" "unintern") + ("uninterned" "uninterned") + ("universal time" "universal_time") + ("unqualified method" "unqualified_method") + ("unregistered package" "unregistered_package") + ("unsafe" "unsafe") + ("unsafe call" "unsafe_call") + ("upgrade" "upgrade") + ("upgraded array element type" "upgraded_array_element_type") + ("upgraded complex part type" "upgraded_complex_part_type") + ("uppercase" "uppercase") + ("use" "use") + ("use list" "use_list") + ("user" "user") + ("valid array dimension" "valid_array_dimension") + ("valid array index" "valid_array_index") + ("valid array row-major index" "valid_array_row-major_index") + ("valid fill pointer" "valid_fill_pointer") + ("valid logical pathname host" "valid_logical_pathname_host") + ("valid pathname device" "valid_pathname_device") + ("valid pathname directory" "valid_pathname_directory") + ("valid pathname host" "valid_pathname_host") + ("valid pathname name" "valid_pathname_name") + ("valid pathname type" "valid_pathname_type") + ("valid pathname version" "valid_pathname_version") + ("valid physical pathname host" "valid_physical_pathname_host") + ("valid sequence index" "valid_sequence_index") + ("value" "value") + ("value cell" "value_cell") + ("variable" "variable") + ("vector" "vector") + ("vertical-bar" "vertical-bar") + ("whitespace" "whitespace") + ("wild" "wild") + ("write" "write") + ("writer" "writer") + ("yield" "yield"))) + +(defun common-lisp-hyperspec-glossary-term (term) + "View the definition of TERM on the Common Lisp Hyperspec." + (interactive + (list + (completing-read "Look up glossary term: " + common-lisp-hyperspec--glossary-terms nil t))) + (browse-url (funcall common-lisp-hyperspec-glossary-function term))) + +(defun common-lisp-glossary-6.0 (term) + "Get a URL for a glossary term TERM." + (let ((anchor (gethash term common-lisp-hyperspec--glossary-terms))) + (if (not anchor) + (message "Unknown glossary term: %s" term) + (format "%sBody/26_glo_%s.htm#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char term))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + anchor)))) + +;; Tianxiang Xiong 20151229 +;; Is this function necessary? The link does created does not work. +(defun common-lisp-glossary-4.0 (string) + (format "%sBody/glo_%s.html#%s" + common-lisp-hyperspec-root + (let ((char (string-to-char string))) + (if (and (<= ?a char) + (<= char ?z)) + (make-string 1 char) + "9")) + (subst-char-in-string ?\ ?_ string))) + + +;;;; Issuex + +;; FIXME: the issuex stuff is not used +(defvar common-lisp-hyperspec-issuex-table nil + "The HyperSpec IssueX table file. If you copy the HyperSpec to your +local system, set this variable to the location of the Issue +cross-references table which is usually \"Map_IssX.txt\" or +\"Issue-Cross-Refs.text\".") + +(defvar common-lisp-hyperspec--issuex-symbols + (make-hash-table :test 'equal)) + +(mapc + (lambda (entry) + (puthash (car entry) (cadr entry) common-lisp-hyperspec--issuex-symbols)) + (if common-lisp-hyperspec-issuex-table + (common-lisp-hyperspec--parse-map-file + common-lisp-hyperspec-issuex-table) + '(("&environment-binding-order:first" "iss001.htm") + ("access-error-name" "iss002.htm") + ("adjust-array-displacement" "iss003.htm") + ("adjust-array-fill-pointer" "iss004.htm") + ("adjust-array-not-adjustable:implicit-copy" "iss005.htm") + ("allocate-instance:add" "iss006.htm") + ("allow-local-inline:inline-notinline" "iss007.htm") + ("allow-other-keys-nil:permit" "iss008.htm") + ("aref-1d" "iss009.htm") + ("argument-mismatch-error-again:consistent" "iss010.htm") + ("argument-mismatch-error-moon:fix" "iss011.htm") + ("argument-mismatch-error:more-clarifications" "iss012.htm") + ("arguments-underspecified:specify" "iss013.htm") + ("array-dimension-limit-implications:all-fixnum" "iss014.htm") + ("array-type-element-type-semantics:unify-upgrading" "iss015.htm") + ("assert-error-type:error" "iss016.htm") + ("assoc-rassoc-if-key" "iss017.htm") + ("assoc-rassoc-if-key:yes" "iss018.htm") + ("boa-aux-initialization:error-on-read" "iss019.htm") + ("break-on-warnings-obsolete:remove" "iss020.htm") + ("broadcast-stream-return-values:clarify-minimally" "iss021.htm") + ("butlast-negative:should-signal" "iss022.htm") + ("change-class-initargs:permit" "iss023.htm") + ("char-name-case:x3j13-mar-91" "iss024.htm") + ("character-loose-ends:fix" "iss025.htm") + ("character-proposal:2" "iss026.htm") + ("character-proposal:2-1-1" "iss027.htm") + ("character-proposal:2-1-2" "iss028.htm") + ("character-proposal:2-2-1" "iss029.htm") + ("character-proposal:2-3-1" "iss030.htm") + ("character-proposal:2-3-2" "iss031.htm") + ("character-proposal:2-3-3" "iss032.htm") + ("character-proposal:2-3-4" "iss033.htm") + ("character-proposal:2-3-5" "iss034.htm") + ("character-proposal:2-3-6" "iss035.htm") + ("character-proposal:2-4-1" "iss036.htm") + ("character-proposal:2-4-2" "iss037.htm") + ("character-proposal:2-4-3" "iss038.htm") + ("character-proposal:2-5-2" "iss039.htm") + ("character-proposal:2-5-6" "iss040.htm") + ("character-proposal:2-5-7" "iss041.htm") + ("character-proposal:2-6-1" "iss042.htm") + ("character-proposal:2-6-2" "iss043.htm") + ("character-proposal:2-6-3" "iss044.htm") + ("character-proposal:2-6-5" "iss045.htm") + ("character-vs-char:less-inconsistent-short" "iss046.htm") + ("class-object-specializer:affirm" "iss047.htm") + ("clos-conditions-again:allow-subset" "iss048.htm") + ("clos-conditions:integrate" "iss049.htm") + ("clos-error-checking-order:no-applicable-method-first" "iss050.htm") + ("clos-macro-compilation:minimal" "iss051.htm") + ("close-constructed-stream:argument-stream-only" "iss052.htm") + ("closed-stream-operations:allow-inquiry" "iss053.htm") + ("coercing-setf-name-to-function:all-function-names" "iss054.htm") + ("colon-number" "iss055.htm") + ("common-features:specify" "iss056.htm") + ("common-type:remove" "iss057.htm") + ("compile-argument-problems-again:fix" "iss058.htm") + ("compile-file-handling-of-top-level-forms:clarify" "iss059.htm") + ("compile-file-output-file-defaults:input-file" "iss060.htm") + ("compile-file-package" "iss061.htm") + ("compile-file-pathname-arguments:make-consistent" "iss062.htm") + ("compile-file-symbol-handling:new-require-consistency" "iss063.htm") + ("compiled-function-requirements:tighten" "iss064.htm") + ("compiler-diagnostics:use-handler" "iss065.htm") + ("compiler-let-confusion:eliminate" "iss066.htm") + ("compiler-verbosity:like-load" "iss067.htm") + ("compiler-warning-stream" "iss068.htm") + ("complex-atan-branch-cut:tweak" "iss069.htm") + ("complex-atanh-bogus-formula:tweak-more" "iss070.htm") + ("complex-rational-result:extend" "iss071.htm") + ("compute-applicable-methods:generic" "iss072.htm") + ("concatenate-sequence:signal-error" "iss073.htm") + ("condition-accessors-setfable:no" "iss074.htm") + ("condition-restarts:buggy" "iss075.htm") + ("condition-restarts:permit-association" "iss076.htm") + ("condition-slots:hidden" "iss077.htm") + ("cons-type-specifier:add" "iss078.htm") + ("constant-circular-compilation:yes" "iss079.htm") + ("constant-collapsing:generalize" "iss080.htm") + ("constant-compilable-types:specify" "iss081.htm") + ("constant-function-compilation:no" "iss082.htm") + ("constant-modification:disallow" "iss083.htm") + ("constantp-definition:intentional" "iss084.htm") + ("constantp-environment:add-arg" "iss085.htm") + ("contagion-on-numerical-comparisons:transitive" "iss086.htm") + ("copy-symbol-copy-plist:copy-list" "iss087.htm") + ("copy-symbol-print-name:equal" "iss088.htm") + ("data-io:add-support" "iss089.htm") + ("data-types-hierarchy-underspecified" "iss090.htm") + ("debugger-hook-vs-break:clarify" "iss091.htm") + ("declaration-scope:no-hoisting" "iss092.htm") + ("declare-array-type-element-references:restrictive" "iss093.htm") + ("declare-function-ambiguity:delete-ftype-abbreviation" "iss094.htm") + ("declare-macros:flush" "iss095.htm") + ("declare-type-free:lexical" "iss096.htm") + ("decls-and-doc" "iss097.htm") + ("decode-universal-time-daylight:like-encode" "iss098.htm") + ("defconstant-special:no" "iss099.htm") + ("defgeneric-declare:allow-multiple" "iss100.htm") + ("define-compiler-macro:x3j13-nov89" "iss101.htm") + ("define-condition-syntax:\ +incompatibly-more-like-defclass+emphasize-read-only" "iss102.htm") + ("define-method-combination-behavior:clarify" "iss103.htm") + ("defining-macros-non-top-level:allow" "iss104.htm") + ("defmacro-block-scope:excludes-bindings" "iss105.htm") + ("defmacro-lambda-list:tighten-description" "iss106.htm") + ("defmethod-declaration-scope:corresponds-to-bindings" "iss107.htm") + ("defpackage:addition" "iss108.htm") + ("defstruct-constructor-key-mixture:allow-key" "iss109.htm") + ("defstruct-constructor-options:explicit" "iss110.htm") + ("defstruct-constructor-slot-variables:not-bound" "iss111.htm") + ("defstruct-copier-argument-type:restrict" "iss112.htm") + ("defstruct-copier:argument-type" "iss113.htm") + ("defstruct-default-value-evaluation:iff-needed" "iss114.htm") + ("defstruct-include-deftype:explicitly-undefined" "iss115.htm") + ("defstruct-print-function-again:x3j13-mar-93" "iss116.htm") + ("defstruct-print-function-inheritance:yes" "iss117.htm") + ("defstruct-redefinition:error" "iss118.htm") + ("defstruct-slots-constraints-name:duplicates-error" "iss119.htm") + ("defstruct-slots-constraints-number" "iss120.htm") + ("deftype-destructuring:yes" "iss121.htm") + ("deftype-key:allow" "iss122.htm") + ("defvar-documentation:unevaluated" "iss123.htm") + ("defvar-init-time:not-delayed" "iss124.htm") + ("defvar-initialization:conservative" "iss125.htm") + ("deprecation-position:limited" "iss126.htm") + ("describe-interactive:no" "iss127.htm") + ("describe-underspecified:describe-object" "iss128.htm") + ("destructive-operations:specify" "iss129.htm") + ("destructuring-bind:new-macro" "iss130.htm") + ("disassemble-side-effect:do-not-install" "iss131.htm") + ("displaced-array-predicate:add" "iss132.htm") + ("do-symbols-block-scope:entire-form" "iss133.htm") + ("do-symbols-duplicates" "iss134.htm") + ("documentation-function-bugs:fix" "iss135.htm") + ("documentation-function-tangled:require-argument" "iss136.htm") + ("dotimes-ignore:x3j13-mar91" "iss137.htm") + ("dotted-list-arguments:clarify" "iss138.htm") + ("dotted-macro-forms:allow" "iss139.htm") + ("dribble-technique" "iss140.htm") + ("dynamic-extent-function:extend" "iss141.htm") + ("dynamic-extent:new-declaration" "iss142.htm") + ("equal-structure:maybe-status-quo" "iss143.htm") + ("error-terminology-warning:might" "iss144.htm") + ("eval-other:self-evaluate" "iss145.htm") + ("eval-top-level:load-like-compile-file" "iss146.htm") + ("eval-when-non-top-level:generalize-eval-new-keywords" "iss147.htm") + ("eval-when-obsolete-keywords:x3j13-mar-1993" "iss148.htm") + ("evalhook-step-confusion:fix" "iss149.htm") + ("evalhook-step-confusion:x3j13-nov-89" "iss150.htm") + ("exit-extent-and-condition-system:like-dynamic-bindings" "iss151.htm") + ("exit-extent:minimal" "iss152.htm") + ("expt-ratio:p.211" "iss153.htm") + ("extensions-position:documentation" "iss154.htm") + ("external-format-for-every-file-connection:minimum" "iss155.htm") + ("extra-return-values:no" "iss156.htm") + ("file-open-error:signal-file-error" "iss157.htm") + ("fixnum-non-portable:tighten-definition" "iss158.htm") + ("flet-declarations" "iss159.htm") + ("flet-declarations:allow" "iss160.htm") + ("flet-implicit-block:yes" "iss161.htm") + ("float-underflow:add-variables" "iss162.htm") + ("floating-point-condition-names:x3j13-nov-89" "iss163.htm") + ("format-atsign-colon" "iss164.htm") + ("format-colon-uparrow-scope" "iss165.htm") + ("format-comma-interval" "iss166.htm") + ("format-e-exponent-sign:force-sign" "iss167.htm") + ("format-op-c" "iss168.htm") + ("format-pretty-print:yes" "iss169.htm") + ("format-string-arguments:specify" "iss170.htm") + ("function-call-evaluation-order:more-unspecified" "iss171.htm") + ("function-composition:jan89-x3j13" "iss172.htm") + ("function-definition:jan89-x3j13" "iss173.htm") + ("function-name:large" "iss174.htm") + ("function-type" "iss175.htm") + ("function-type-argument-type-semantics:restrictive" "iss176.htm") + ("function-type-key-name:specify-keyword" "iss177.htm") + ("function-type-rest-list-element:use-actual-argument-type" "iss178.htm") + ("function-type:x3j13-march-88" "iss179.htm") + ("generalize-pretty-printer:unify" "iss180.htm") + ("generic-flet-poorly-designed:delete" "iss181.htm") + ("gensym-name-stickiness:like-teflon" "iss182.htm") + ("gentemp-bad-idea:deprecate" "iss183.htm") + ("get-macro-character-readtable:nil-standard" "iss184.htm") + ("get-setf-method-environment:add-arg" "iss185.htm") + ("hash-table-access:x3j13-mar-89" "iss186.htm") + ("hash-table-key-modification:specify" "iss187.htm") + ("hash-table-package-generators:add-with-wrapper" "iss188.htm") + ("hash-table-rehash-size-integer" "iss189.htm") + ("hash-table-size:intended-entries" "iss190.htm") + ("hash-table-tests:add-equalp" "iss191.htm") + ("ieee-atan-branch-cut:split" "iss192.htm") + ("ignore-use-terminology:value-only" "iss193.htm") + ("import-setf-symbol-package" "iss194.htm") + ("in-package-functionality:mar89-x3j13" "iss195.htm") + ("in-syntax:minimal" "iss196.htm") + ("initialization-function-keyword-checking" "iss197.htm") + ("iso-compatibility:add-substrate" "iss198.htm") + ("jun90-trivial-issues:11" "iss199.htm") + ("jun90-trivial-issues:14" "iss200.htm") + ("jun90-trivial-issues:24" "iss201.htm") + ("jun90-trivial-issues:25" "iss202.htm") + ("jun90-trivial-issues:27" "iss203.htm") + ("jun90-trivial-issues:3" "iss204.htm") + ("jun90-trivial-issues:4" "iss205.htm") + ("jun90-trivial-issues:5" "iss206.htm") + ("jun90-trivial-issues:9" "iss207.htm") + ("keyword-argument-name-package:any" "iss208.htm") + ("last-n" "iss209.htm") + ("lcm-no-arguments:1" "iss210.htm") + ("lexical-construct-global-definition:undefined" "iss211.htm") + ("lisp-package-name:common-lisp" "iss212.htm") + ("lisp-symbol-redefinition-again:more-fixes" "iss213.htm") + ("lisp-symbol-redefinition:mar89-x3j13" "iss214.htm") + ("load-objects:make-load-form" "iss215.htm") + ("load-time-eval:r**2-new-special-form" "iss216.htm") + ("load-time-eval:r**3-new-special-form" "iss217.htm") + ("load-truename:new-pathname-variables" "iss218.htm") + ("locally-top-level:special-form" "iss219.htm") + ("loop-and-discrepancy:no-reiteration" "iss220.htm") + ("loop-for-as-on-typo:fix-typo" "iss221.htm") + ("loop-initform-environment:partial-interleaving-vague" "iss222.htm") + ("loop-miscellaneous-repairs:fix" "iss223.htm") + ("loop-named-block-nil:override" "iss224.htm") + ("loop-present-symbols-typo:flush-wrong-words" "iss225.htm") + ("loop-syntax-overhaul:repair" "iss226.htm") + ("macro-as-function:disallow" "iss227.htm") + ("macro-declarations:make-explicit" "iss228.htm") + ("macro-environment-extent:dynamic" "iss229.htm") + ("macro-function-environment" "iss230.htm") + ("macro-function-environment:yes" "iss231.htm") + ("macro-subforms-top-level-p:add-constraints" "iss232.htm") + ("macroexpand-hook-default:explicitly-vague" "iss233.htm") + ("macroexpand-hook-initial-value:implementation-dependent" "iss234.htm") + ("macroexpand-return-value:true" "iss235.htm") + ("make-load-form-confusion:rewrite" "iss236.htm") + ("make-load-form-saving-slots:no-initforms" "iss237.htm") + ("make-package-use-default:implementation-dependent" "iss238.htm") + ("map-into:add-function" "iss239.htm") + ("mapping-destructive-interaction:explicitly-vague" "iss240.htm") + ("metaclass-of-system-class:unspecified" "iss241.htm") + ("method-combination-arguments:clarify" "iss242.htm") + ("method-initform:forbid-call-next-method" "iss243.htm") + ("muffle-warning-condition-argument" "iss244.htm") + ("multiple-value-setq-order:like-setf-of-values" "iss245.htm") + ("multiple-values-limit-on-variables:undefined" "iss246.htm") + ("nintersection-destruction" "iss247.htm") + ("nintersection-destruction:revert" "iss248.htm") + ("not-and-null-return-value:x3j13-mar-93" "iss249.htm") + ("nth-value:add" "iss250.htm") + ("optimize-debug-info:new-quality" "iss251.htm") + ("package-clutter:reduce" "iss252.htm") + ("package-deletion:new-function" "iss253.htm") + ("package-function-consistency:more-permissive" "iss254.htm") + ("parse-error-stream:split-types" "iss255.htm") + ("pathname-component-case:keyword-argument" "iss256.htm") + ("pathname-component-value:specify" "iss257.htm") + ("pathname-host-parsing:recognize-logical-host-names" "iss258.htm") + ("pathname-logical:add" "iss259.htm") + ("pathname-print-read:sharpsign-p" "iss260.htm") + ("pathname-stream" "iss261.htm") + ("pathname-stream:files-or-synonym" "iss262.htm") + ("pathname-subdirectory-list:new-representation" "iss263.htm") + ("pathname-symbol" "iss264.htm") + ("pathname-syntax-error-time:explicitly-vague" "iss265.htm") + ("pathname-unspecific-component:new-token" "iss266.htm") + ("pathname-wild:new-functions" "iss267.htm") + ("peek-char-read-char-echo:first-read-char" "iss268.htm") + ("plist-duplicates:allow" "iss269.htm") + ("pretty-print-interface" "iss270.htm") + ("princ-readably:x3j13-dec-91" "iss271.htm") + ("print-case-behavior:clarify" "iss272.htm") + ("print-case-print-escape-interaction:vertical-bar-rule-no-upcase" + "iss273.htm") + ("print-circle-shared:respect-print-circle" "iss274.htm") + ("print-circle-structure:user-functions-work" "iss275.htm") + ("print-readably-behavior:clarify" "iss276.htm") + ("printer-whitespace:just-one-space" "iss277.htm") + ("proclaim-etc-in-compile-file:new-macro" "iss278.htm") + ("push-evaluation-order:first-item" "iss279.htm") + ("push-evaluation-order:item-first" "iss280.htm") + ("pushnew-store-required:unspecified" "iss281.htm") + ("quote-semantics:no-copying" "iss282.htm") + ("range-of-count-keyword:nil-or-integer" "iss283.htm") + ("range-of-start-and-end-parameters:integer-and-integer-nil" "iss284.htm") + ("read-and-write-bytes:new-functions" "iss285.htm") + ("read-case-sensitivity:readtable-keywords" "iss286.htm") + ("read-modify-write-evaluation-order:delayed-access-stores" "iss287.htm") + ("read-suppress-confusing:generalize" "iss288.htm") + ("reader-error:new-type" "iss289.htm") + ("real-number-type:x3j13-mar-89" "iss290.htm") + ("recursive-deftype:explicitly-vague" "iss291.htm") + ("reduce-argument-extraction" "iss292.htm") + ("remf-destruction-unspecified:x3j13-mar-89" "iss293.htm") + ("require-pathname-defaults-again:x3j13-dec-91" "iss294.htm") + ("require-pathname-defaults-yet-again:restore-argument" "iss295.htm") + ("require-pathname-defaults:eliminate" "iss296.htm") + ("rest-list-allocation:may-share" "iss297.htm") + ("result-lists-shared:specify" "iss298.htm") + ("return-values-unspecified:specify" "iss299.htm") + ("room-default-argument:new-value" "iss300.htm") + ("self-modifying-code:forbid" "iss301.htm") + ("sequence-type-length:must-match" "iss302.htm") + ("setf-apply-expansion:ignore-expander" "iss303.htm") + ("setf-find-class:allow-nil" "iss304.htm") + ("setf-functions-again:minimal-changes" "iss305.htm") + ("setf-get-default:evaluated-but-ignored" "iss306.htm") + ("setf-macro-expansion:last" "iss307.htm") + ("setf-method-vs-setf-method:rename-old-terms" "iss308.htm") + ("setf-multiple-store-variables:allow" "iss309.htm") + ("setf-of-apply:only-aref-and-friends" "iss310.htm") + ("setf-of-values:add" "iss311.htm") + ("setf-sub-methods:delayed-access-stores" "iss312.htm") + ("shadow-already-present" "iss313.htm") + ("shadow-already-present:works" "iss314.htm") + ("sharp-comma-confusion:remove" "iss315.htm") + ("sharp-o-foobar:consequences-undefined" "iss316.htm") + ("sharp-star-delimiter:normal-delimiter" "iss317.htm") + ("sharpsign-plus-minus-package:keyword" "iss318.htm") + ("slot-missing-values:specify" "iss319.htm") + ("slot-value-metaclasses:less-minimal" "iss320.htm") + ("special-form-p-misnomer:rename" "iss321.htm") + ("special-type-shadowing:clarify" "iss322.htm") + ("standard-input-initial-binding:defined-contracts" "iss323.htm") + ("standard-repertoire-gratuitous:rename" "iss324.htm") + ("step-environment:current" "iss325.htm") + ("step-minimal:permit-progn" "iss326.htm") + ("stream-access:add-types-accessors" "iss327.htm") + ("stream-capabilities:interactive-stream-p" "iss328.htm") + ("string-coercion:make-consistent" "iss329.htm") + ("string-output-stream-bashing:undefined" "iss330.htm") + ("structure-read-print-syntax:keywords" "iss331.htm") + ("subseq-out-of-bounds" "iss332.htm") + ("subseq-out-of-bounds:is-an-error" "iss333.htm") + ("subsetting-position:none" "iss334.htm") + ("subtypep-environment:add-arg" "iss335.htm") + ("subtypep-too-vague:clarify-more" "iss336.htm") + ("sxhash-definition:similar-for-sxhash" "iss337.htm") + ("symbol-macrolet-declare:allow" "iss338.htm") + ("symbol-macrolet-semantics:special-form" "iss339.htm") + ("symbol-macrolet-type-declaration:no" "iss340.htm") + ("symbol-macros-and-proclaimed-specials:signals-an-error" "iss341.htm") + ("symbol-print-escape-behavior:clarify" "iss342.htm") + ("syntactic-environment-access:retracted-mar91" "iss343.htm") + ("tagbody-tag-expansion:no" "iss344.htm") + ("tailp-nil:t" "iss345.htm") + ("test-not-if-not:flush-all" "iss346.htm") + ("the-ambiguity:for-declaration" "iss347.htm") + ("the-values:return-number-received" "iss348.htm") + ("time-zone-non-integer:allow" "iss349.htm") + ("type-declaration-abbreviation:allow-all" "iss350.htm") + ("type-of-and-predefined-classes:type-of-handles-floats" "iss351.htm") + ("type-of-and-predefined-classes:unify-and-extend" "iss352.htm") + ("type-of-underconstrained:add-constraints" "iss353.htm") + ("type-specifier-abbreviation:x3j13-jun90-guess" "iss354.htm") + ("undefined-variables-and-functions:compromise" "iss355.htm") + ("uninitialized-elements:consequences-undefined" "iss356.htm") + ("unread-char-after-peek-char:dont-allow" "iss357.htm") + ("unsolicited-messages:not-to-system-user-streams" "iss358.htm") + ("variable-list-asymmetry:symmetrize" "iss359.htm") + ("with-added-methods:delete" "iss360.htm") + ("with-compilation-unit:new-macro" "iss361.htm") + ("with-open-file-does-not-exist:stream-is-nil" "iss362.htm") + ("with-open-file-setq:explicitly-vague" "iss363.htm") + ("with-open-file-stream-extent:dynamic-extent" "iss364.htm") + ("with-output-to-string-append-style:vector-push-extend" "iss365.htm") + ("with-standard-io-syntax-readtable:x3j13-mar-91" "iss366.htm")))) + +(defun common-lisp-issuex (issue-name) + (let ((entry (gethash (downcase issue-name) + common-lisp-hyperspec--issuex-symbols))) + (concat common-lisp-hyperspec-root "Issues/" entry))) + +;;; Added the following just to provide a common entry point according +;;; to the various 'hyperspec' implementations. +;;; +;;; 19990820 Marco Antoniotti + +(defalias 'hyperspec-lookup 'common-lisp-hyperspec) +(defalias 'hyperspec-lookup-reader-macro + 'common-lisp-hyperspec-lookup-reader-macro) +(defalias 'hyperspec-lookup-format 'common-lisp-hyperspec-format) + +(provide 'hyperspec) + +;;; hyperspec.el ends here blob - /dev/null blob + cfaf0a3d3ff0c581dcccb86fd76b6a356fd39ea2 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-buttons.el @@ -0,0 +1,324 @@ +;;; sly-buttons.el --- Button-related utils for SLY -*- lexical-binding: t; -*- +;;; +(require 'cl-lib) +(require 'sly-messages "lib/sly-messages") + +(defvar sly-part-button-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map button-map) + (define-key map [down-mouse-3] 'sly-button-popup-part-menu) + (define-key map [mouse-3] 'sly-button-popup-part-menu) + (define-key map [mouse-1] 'push-button) + (define-key map [return] 'push-button) + map)) + +(defvar sly-button-popup-part-menu-keymap + (let ((map (make-sparse-keymap))) + map)) + +(defun sly-button-popup-part-menu (event) + "Popup a menu for a `sly-part' button" + (interactive "@e") + (let* ((button (button-at (posn-point (event-end event)))) + (label (button-get button 'part-label)) + (items (cdr (button-get button 'part-menu-keymap)))) + (popup-menu + `(keymap + ,@(when label + `(,(truncate-string-to-width label 30 nil nil t))) + ,@items)))) + +(defun sly-button-at (&optional pos type no-error) + (let ((button (button-at (or pos + (if (mouse-event-p last-input-event) + (posn-point (event-start last-input-event)) + (point)))))) + (cond ((and button type + (button-type-subtype-p (button-type button) type)) + button) + ((and button type) + (unless no-error + (error "[sly] Button at point is not of expected type %s" type))) + (button + button) + (t + (unless no-error + (error "[sly] No button at point")))))) + +(defun sly-button-buttons-in (beg end) + (save-excursion + (goto-char (point-min)) + (cl-loop for count-current = t then nil + for button = (next-button (point) count-current) + while button + do (goto-char (button-start button)) + collect button))) + +(defmacro sly-button-define-part-action (action label key) + `(progn + (defun ,action (button) + ,(format "%s the object under BUTTON." + label) + (interactive (list (sly-button-at))) + (let ((fn (button-get button ',action)) + (args (button-get button 'part-args))) + (if (and + (sly-current-connection) + (eq (button-get button 'sly-connection) + (sly-current-connection))) + (cond ((and fn args) + (apply fn args)) + (args + (sly-error "button of type `%s' doesn't implement `%s'" + (button-type button) ',action)) + (fn + (sly-error "button %s doesn't have the `part-args' property" + button))) + (sly-error (format "button is from an older connection"))))) + ,@(when key + `((define-key sly-part-button-keymap ,key + '(menu-item "" ,action + :filter (lambda (cmd) + (let ((button (sly-button-at nil nil 'no-error))) + (and button + (button-get button ',action) + cmd))))))) + (define-key sly-button-popup-part-menu-keymap + [,action] '(menu-item ,label ,action + :visible (let ((button (sly-button-at nil nil 'no-error))) + (and button + (button-get button ',action))))))) + +(sly-button-define-part-action sly-button-inspect "Inspect" (kbd "i")) +(sly-button-define-part-action sly-button-describe "Describe" (kbd "d")) +(sly-button-define-part-action sly-button-pretty-print "Pretty Print" (kbd "p")) +(sly-button-define-part-action sly-button-show-source "Show Source" (kbd "v")) +(sly-button-define-part-action sly-button-goto-source "Go To Source" (kbd ".")) + +(defun sly--make-text-button (beg end &rest properties) + "Just like `make-text-button', but add sly-specifics." + (apply #'make-text-button beg end + 'sly-connection (sly-current-connection) + properties)) + +(defun sly-make-action-button (label action &rest props) + (apply #'sly--make-text-button + label nil :type 'sly-action + 'action action + 'mouse-action action + props)) + +(defface sly-action-face + `((t (:inherit warning))) + "Face for SLY buttons." + :group 'sly) + +(define-button-type 'sly-button + 'sly-button-search-id 'regular-button) + +(define-button-type 'sly-action :supertype 'sly-button + 'face 'sly-action-face + 'mouse-face 'highlight + 'sly-button-echo 'sly-button-echo-button) + +(defface sly-part-button-face + '((t (:inherit font-lock-constant-face))) + "Face for things which be interactively inspected, etc" + :group 'sly) + +(define-button-type 'sly-part :supertype 'sly-button + 'face 'sly-part-button-face + 'action 'sly-button-inspect + 'mouse-action 'sly-button-inspect + 'keymap sly-part-button-keymap + 'sly-button-echo 'sly-button-echo-part + 'part-menu-keymap sly-button-popup-part-menu-keymap + 'help-echo "RET, mouse-2: Inspect object; mouse-3: Context menu" + ;; these are ajust here for clarity + ;; + 'sly-button-inspect nil + 'sly-button-describe nil + 'sly-button-pretty-print nil + 'sly-button-show-source nil) + +(cl-defun sly-button-flash (button &key + (face 'highlight) + (pattern '(0.07 0.07 0.07 0.07)) + times + timeout) + (sly-flash-region (button-start button) (button-end button) + :timeout timeout + :pattern pattern + :times times + :face face)) + + +(defun sly-button-echo-button (button) (sly-message "A sly button")) + +(defun sly-button-echo-part (button) + (sly-button-flash button) + (sly-message (button-get button 'part-label))) + + +;;; Overlay-button specifics +;;; +(defun sly-button--overlays-in (beg end &optional filter) + "Return overlays overlapping positions BEG and END" + (cl-remove-if-not #'(lambda (button) + (and + ;; Workaround fragility in Emacs' buttons: + ;; `button-type-subtype-p' errors when + ;; `button' is not actually a button. A + ;; straightforward predicate for this doesn't + ;; seem to exist yet. + (ignore-errors + (button-type-subtype-p (button-type button) 'sly-button)) + (or (not filter) + (funcall filter button)))) + (overlays-in beg end))) + +(defun sly-button--overlays-between (beg end &optional filter) + "Return overlays contained entirely between BEG and END" + (cl-remove-if-not #'(lambda (button) + (and (>= (button-start button) beg) + (<= (button-end button) end))) + (sly-button--overlays-in beg end filter))) + +(defun sly-button--overlays-exactly-at (beg end &optional filter) + "Return overlays exactly between BEG and END" + (cl-remove-if-not #'(lambda (button) + (and (= (button-start button) beg) + (= (button-end button) end))) + (sly-button--overlays-in beg end filter))) + +(defun sly-button--overlays-at (&optional point filter) + "Return overlays near POINT" + (let ((point (or point (point)))) + (cl-sort (sly-button--overlays-in (1- point) (1+ point) filter) + #'> :key #'sly-button--level))) + +(gv-define-setter sly-button--level (level button) + `(overlay-put ,button 'sly-button-level ,level)) + +(defun sly-button--level (button) + (or (overlay-get button 'sly-button-level) 0)) + + + +;;; Button navigation +;;; +(defvar sly-button--next-search-id 0) + +(defun sly-button-next-search-id () + (cl-incf sly-button--next-search-id)) + +(defun sly-button--searchable-buttons-at (pos filter) + (let* ((probe (sly-button-at pos 'sly-button 'no-error)) + (non-overlay-button (and probe + (not (overlayp probe)) + probe))) + (cl-remove-duplicates + (append (sly-button--overlays-at pos filter) + (if (and non-overlay-button + (or (not filter) + (funcall filter non-overlay-button))) + (list non-overlay-button)))))) + +(defun sly-button--searchable-buttons-starting-at (&optional point filter) + (let ((point (or point (point)))) + (cl-remove-if-not #'(lambda (button) + (= (button-start button) point)) + (sly-button--searchable-buttons-at point filter)))) + +(defun sly-button--search-1 (n filter) + (cl-loop with off-by-one = (if (cl-plusp n) -1 +1) + for search-start = (point) then pos + for preval = (and (not (cond ((cl-plusp n) + (= search-start (point-min))) + (t + (= search-start (point-max))))) + (get-char-property (+ off-by-one + search-start) + 'sly-button-search-id)) + for pos = (funcall + (if (cl-plusp n) + #'next-single-char-property-change + #'previous-single-char-property-change) + search-start + 'sly-button-search-id) + for newval = (get-char-property pos 'sly-button-search-id) + until (cond ((cl-plusp n) + (= pos (point-max))) + (t + (= pos (point-min)))) + for buttons = (sly-button--searchable-buttons-at + pos (or filter #'identity)) + when (and buttons + newval + (not (eq newval preval)) + (eq pos (button-start (car buttons)))) + return buttons)) + + +(put 'sly-button-forward 'sly-button-navigation-command t) +(put 'sly-button-backward 'sly-button-navigation-command t) + +(defun sly-button-search (n &optional filter) + "Go forward to Nth buttons verifying FILTER and echo it. + +With negative N, go backward. Visiting is done via the +`sly-button-echo' property. + +If more than one button overlap the same region, the button +starting before is visited first. If more than one button start +at exactly the same spot, they are both visited simultaneously, +`sly-button-echo' being passed a variable number of button arguments." + (cl-loop for i from 0 below (abs n) + for buttons = + (or (and (not (and + ;; (symbolp last-command) + (get last-command 'sly-button-navigation-command))) + (sly-button--searchable-buttons-starting-at (point) filter)) + (sly-button--search-1 n filter)) + for button = (car buttons) + while buttons + finally + (cond (buttons + (goto-char (button-start (car buttons))) + (apply (button-get button 'sly-button-echo) + button + (cl-remove-if-not + #'(lambda (b) + (= (button-start b) (button-start button))) + (cdr buttons)))) + (t + (sly-user-error "No more buttons!"))))) + +(defvar sly-button-filter-function #'identity + "Filter buttons considered by `sly-button-forward' +Set to `sly-note-button-p' to only navigate compilation notes, +or leave at `identity' to visit every `sly-button' in the buffer.'") + +(defun sly-button-forward (n) + "Go to and describe the next button in the buffer." + (interactive "p") + (sly-button-search n sly-button-filter-function)) + +(defun sly-button-backward (n) + "Go to and describe the previous button in the buffer." + (interactive "p") + (sly-button-forward (- n))) + +(define-minor-mode sly-interactive-buttons-mode + "Minor mode where text property SLY buttons exist" + nil nil nil + ;; Prevent strings copied from SLY buffers and yanked to source + ;; buffers to land with misleading `sly-' properties. + (when (fboundp 'add-function) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'substring-no-properties + '((name . sly-remove-string-properties))))) + +(provide 'sly-buttons) + +;;; sly-buttons.el ends here blob - /dev/null blob + d1da5816de67aa61723ee95913a856e3fde6546a (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-cl-indent.el @@ -0,0 +1,1796 @@ +;;; sly-cl-indent.el --- enhanced lisp-indent mode -*- lexical-binding: t; -*- + +;; Copyright (C) 1987, 2000-2011 Free Software Foundation, Inc. + +;; Author: Richard Mlynarik +;; Created: July 1987 +;; Maintainer: FSF +;; Keywords: lisp, tools +;; Package: emacs + +;; This file is forked from cl-indent.el, which 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 3 of the License, 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. If not, see . + +;;; Commentary: + +;; This package supplies a single entry point, `sly-common-lisp-indent-function', +;; which performs indentation in the preferred style for Common Lisp code. +;; To enable it: +;; +;; (setq lisp-indent-function 'sly-common-lisp-indent-function) +;; +;; This file is substantially patched from original cl-indent.el, +;; which is in Emacs proper. Although it is named after the SLY +;; library, it DOES NOT require it. sly-cl-indent is instead required +;; by one of SLY's contribs, `sly-indentation'. +;; +;; Before making modifications to this file, consider adding them to +;; Emacs's own `cl-indent' and refactoring this file to be an +;; extension of Emacs's. +;; +;;; Code: +(require 'cl-lib) + +(defgroup sly-lisp-indent nil + "Indentation in Common Lisp." + :group 'sly + :group 'lisp-indent) + +(defcustom sly-lisp-indent-maximum-backtracking 6 + "Maximum depth to backtrack out from a sublist for structured indentation. +If this variable is 0, no backtracking will occur and forms such as `flet' +may not be correctly indented if this value is less than 4." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-tag-indentation 1 + "Indentation of tags relative to containing list. +This variable is used by the function `sly--lisp-indent-tagbody'." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-tag-body-indentation 3 + "Indentation of non-tagged lines relative to containing list. +This variable is used by the function `sly--lisp-indent-tagbody' to indent normal +lines (lines without tags). +The indentation is relative to the indentation of the parenthesis enclosing +the special form. If the value is t, the body of tags will be indented +as a block at the same indentation as the first s-expression following +the tag. In this case, any forms before the first tag are indented +by `lisp-body-indent'." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-backquote-indentation t + "Whether or not to indent backquoted lists as code. +If nil, indent backquoted lists as data, i.e., like quoted lists." + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-loop-indent-subclauses t + "Whether or not to indent loop subclauses." + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-simple-loop-indentation 2 + "Indentation of forms in simple loop forms." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-loop-clauses-indentation 2 + "Indentation of loop clauses if `loop' is immediately followed by a newline." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-loop-indent-body-forms-relative-to-loop-start nil + "When true, indent loop body clauses relative to the open paren of the loop +form, instead of the keyword position." + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-loop-body-forms-indentation 3 + "Indentation of loop body clauses." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-loop-indent-forms-like-keywords nil + "Whether or not to indent loop subforms just like +loop keywords. Only matters when `sly-lisp-loop-indent-subclauses' +is nil." + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-align-keywords-in-calls t + "Whether to align keyword arguments vertically or not. +If t (the default), keywords in contexts where no other +indentation rule takes precedence are aligned like this: + +\(make-instance 'foo :bar t + :quux 42) + +If nil, they are indented like any other function +call arguments: + +\(make-instance 'foo :bar t + :quux 42)" + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-lambda-list-indentation t + "Whether to indent lambda-lists specially. Defaults to t. Setting this to +nil makes `sly-lisp-lambda-list-keyword-alignment', +`sly-lisp-lambda-list-keyword-parameter-alignment', and +`sly-lisp-lambda-list-keyword-parameter-indentation' meaningless, causing +lambda-lists to be indented as if they were data: + +\(defun example (a b &optional o1 o2 + o3 o4 + &rest r + &key k1 k2 + k3 k4) + #|...|#)" + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-lambda-list-keyword-alignment nil + "Whether to vertically align lambda-list keywords together. +If nil (the default), keyworded lambda-list parts are aligned +with the initial mandatory arguments, like this: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#) + +If non-nil, alignment is done with the first keyword +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &rest rest + &key key1 key2) + #|...|#)" + :type 'boolean + :group 'sly-lisp-indent) + +(defcustom sly-lisp-lambda-list-keyword-parameter-indentation 2 + "Indentation of lambda list keyword parameters. +See `sly-lisp-lambda-list-keyword-parameter-alignment' +for more information." + :type 'integer + :group 'sly-lisp-indent) + +(defcustom sly-lisp-lambda-list-keyword-parameter-alignment nil + "Whether to vertically align lambda-list keyword parameters together. +If nil (the default), the parameters are aligned +with their corresponding keyword, plus the value of +`sly-lisp-lambda-list-keyword-parameter-indentation', like this: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#) + +If non-nil, alignment is done with the first parameter +\(or falls back to the previous case), as in: + +\(defun foo (arg1 arg2 &key key1 key2 + key3 key4) + #|...|#)" + :type 'boolean + :group 'sly-lisp-indent) + + +;; should this be a defcustom? +(defvar sly-lisp-indent-defun-method '(4 &lambda &body) + "Defun-like indentation method. +This applies when the value of the `sly-common-lisp-indent-function' property +is set to `defun'.") + + +;;;; Named styles. +;;;; +;;;; -*- common-lisp-style: foo -*- +;;;; +;;;; sets the style for the buffer. +;;;; +;;;; A Common Lisp style is a list of the form: +;;;; +;;;; (NAME INHERIT VARIABLES INDENTATION HOOK DOCSTRING) +;;;; +;;;; where NAME is a symbol naming the style, INHERIT is the name of the style +;;;; it inherits from, VARIABLES is an alist specifying buffer local variables +;;;; for the style, and INDENTATION is an alist specifying non-standard +;;;; indentations for Common Lisp symbols. HOOK is a function to call when +;;;; activating the style. DOCSTRING is the documentation for the style. +;;;; +;;;; Convenience accessors `sly--common-lisp-style-name', &co exist. +;;;; +;;;; `sly-common-lisp-style' stores the name of the current style. +;;;; +;;;; `sly-common-lisp-style-default' stores the name of the style to use when none +;;;; has been specified. +;;;; +;;;; `sly--lisp-indent-active-style' stores a cons of the list specifying the +;;;; current style, and a hash-table containing all indentation methods of that +;;;; style and any styles it inherits from. Whenever we're indenting, we check +;;;; that this is up to date, and recompute when necessary. +;;;; +;;;; Just setting the buffer local sly-common-lisp-style will be enough to have +;;;; the style take effect. `sly-common-lisp-set-style' can also be called +;;;; explicitly, however, and offers name completion, etc. + +(cl-defstruct (sly--common-lisp-style + (:type list) + (:copier nil) + (:predicate nil) + (:constructor nil) + (:constructor sly--common-lisp-make-style + (name inherits variables + indentation hook docstring))) + name inherits variables indentation hook docstring) + +;;; Convenience accessors +(defalias 'sly--lisp-indent-parse-state-start #'cl-second) +(defalias 'sly--lisp-indent-parse-state-prev #'cl-third) + +(defvar-local sly-common-lisp-style nil) + +;;; `sly-define-common-lisp-style' updates the docstring of +;;; `sly-common-lisp-style', using this as the base. +(put 'sly-common-lisp-style 'sly-common-lisp-style-base-doc + "Name of the Common Lisp indentation style used in the current buffer. +Set this by giving eg. + + ;; -*- common-lisp-style: sbcl -*- + +in the first line of the file, or by calling `sly-common-lisp-set-style'. If +buffer has no style specified, but `sly-common-lisp-style-default' is set, that +style is used instead. Use `sly-define-common-lisp-style' to define new styles.") + +;;; `lisp-mode' kills all buffer-local variables. Setting the +;;; `permanent-local' property allows us to retain the style. +(put 'sly-common-lisp-style 'permanent-local t) + +;;; Mark as safe when the style doesn't evaluate arbitrary code. +(put 'sly-common-lisp-style 'safe-local-variable 'sly--lisp-indent-safe-style-p) + +;;; Common Lisp indentation style specifications. +(defvar sly--common-lisp-styles (make-hash-table :test 'equal)) + +;; unused +(defsubst sly--lisp-indent-delete-style (stylename) + (remhash stylename sly--common-lisp-styles)) + +(defun sly--lisp-indent-find-style (stylename) + (let ((name (if (symbolp stylename) + (symbol-name stylename) + stylename))) + (or (gethash name sly--common-lisp-styles) + (error "Unknown Common Lisp style: %s" name)))) + +(defun sly--lisp-indent-safe-style-p (stylename) + "True for known Common Lisp style without an :EVAL option. +Ie. styles that will not evaluate arbitrary code on activation." + (let* ((style (ignore-errors (sly--lisp-indent-find-style stylename))) + (base (sly--common-lisp-style-inherits style))) + (and style + (not (sly--common-lisp-style-hook style)) + (or (not base) + (sly--lisp-indent-safe-style-p base))))) + +(defun sly--lisp-indent-add-style (stylename inherits variables + indentation hooks documentation) + ;; Invalidate indentation methods cached in common-lisp-active-style. + (maphash (lambda (k v) + (puthash k (cl-copy-list v) sly--common-lisp-styles)) + sly--common-lisp-styles) + ;; Add/Redefine the specified style. + (puthash stylename + (sly--common-lisp-make-style + stylename inherits + variables indentation + hooks documentation) + sly--common-lisp-styles) + ;; Frob `sly-common-lisp-style' docstring. + (let ((doc (get 'sly-common-lisp-style + 'sly-common-lisp-style-base-doc)) + (all nil)) + (setq doc (concat doc "\n\nAvailable styles are:\n")) + (maphash (lambda (name style) + (push (list name (sly--common-lisp-style-docstring style)) all)) + sly--common-lisp-styles) + (dolist (info (sort all (lambda (a b) (string< (car a) (car b))))) + (let ((style-name (cl-first info)) + (style-doc (cl-second info))) + (if style-doc + (setq doc (concat doc + "\n " style-name "\n" + " " style-doc "\n")) + (setq doc (concat doc "\n " style-name " (undocumented)\n"))))) + (put 'sly-common-lisp-style 'variable-documentation doc)) + stylename) + +;;; Activate STYLENAME, adding its indentation methods to METHODS -- and +;;; recurse on style inherited from. +(defun sly--lisp-indent-activate-style (stylename methods) + (let* ((style (sly--lisp-indent-find-style stylename)) + (basename (sly--common-lisp-style-inherits style))) + ;; Recurse on parent. + (when basename + (sly--lisp-indent-activate-style basename methods)) + ;; Copy methods + (dolist (spec (sly--common-lisp-style-indentation style)) + (puthash (cl-first spec) (cl-second spec) methods)) + ;; Bind variables. + (dolist (var (sly--common-lisp-style-variables style)) + (set (make-local-variable (cl-first var)) (cl-second var))) + ;; Run hook. + (let ((hook (sly--common-lisp-style-hook style))) + (when hook + (funcall hook))))) + +;;; When a style is being used, `sly--lisp-indent-active-style' holds a cons +;;; +;;; (STYLE . METHODS) +;;; +;;; where STYLE is the list specifying the currently active style, and +;;; METHODS is the table of indentation methods -- including inherited +;;; ones -- for it. `sly--lisp-indent-active-style-methods' is reponsible +;;; for keeping this up to date. +(defvar-local sly--lisp-indent-active-style nil) + +;;; Makes sure sly--lisp-indent-active-style corresponds to sly-common-lisp-style, and +;;; pick up redefinitions, etc. Returns the method table for the currently +;;; active style. +(defun sly--lisp-indent-active-style-methods () + (let* ((name (or sly-common-lisp-style (bound-and-true-p common-lisp-style))) + (style (when name (sly--lisp-indent-find-style name)))) + (if (eq style (car sly--lisp-indent-active-style)) + (cdr sly--lisp-indent-active-style) + (when style + (let ((methods (make-hash-table :test 'equal))) + (sly--lisp-indent-activate-style name methods) + (setq sly--lisp-indent-active-style (cons style methods)) + methods))))) + +(defvar sly--lisp-indent-set-style-history nil) + +(defun sly--lisp-indent-style-names () + (let (names) + (maphash (lambda (k v) + (push (cons k v) names)) + sly--common-lisp-styles) + names)) + +;;;###autoload +(defun sly-common-lisp-set-style (stylename) + "Set current buffer to use the Common Lisp style STYLENAME. +STYLENAME, a string, must be an existing Common Lisp style. Styles +are added (and updated) using `sly-define-common-lisp-style'. + +The buffer-local variable `sly-common-lisp-style' will get set to STYLENAME. + +A Common Lisp style is composed of local variables, indentation +specifications, and may also contain arbitrary elisp code to run upon +activation." + (interactive + (list (let ((completion-ignore-case t) + (prompt "Specify Common Lisp indentation style: ")) + (completing-read prompt + (sly--lisp-indent-style-names) nil t nil + 'sly--lisp-indent-set-style-history)))) + (setq sly-common-lisp-style (sly--common-lisp-style-name + (sly--lisp-indent-find-style stylename)) + sly--lisp-indent-active-style nil) + ;; Actually activates the style. + (sly--lisp-indent-active-style-methods) + stylename) + +;;;###autoload +(defmacro sly-define-common-lisp-style (name documentation &rest options) + "Define a Common Lisp indentation style. + +NAME is the name of the style. + +DOCUMENTATION is the docstring for the style, automatically added to the +docstring of `sly-common-lisp-style'. + +OPTIONS are: + + (:variables (name value) ...) + + Specifying the buffer local variables associated with the style. + + (:indentation (symbol spec) ...) + + Specifying custom indentations associated with the style. SPEC is + a normal `sly-common-lisp-indent-function' indentation specification. + + (:inherit style) + + Inherit variables and indentations from another Common Lisp style. + + (:eval form ...) + + Lisp code to evaluate when activating the style. This can be used to + eg. activate other modes. It is possible that over the lifetime of + a buffer same style gets activated multiple times, so code in :eval + option should cope with that. +" + (declare (indent 1)) + (when (consp documentation) + (setq options (cons documentation options) + documentation nil)) + `(sly--lisp-indent-add-style ,name + ,(cadr (assoc :inherit options)) + ',(cdr (assoc :variables options)) + ',(cdr (assoc :indentation options)) + ,(when (assoc :eval options) + `(lambda () + ,@(cdr (assoc :eval options)))) + ,documentation)) + +(sly-define-common-lisp-style "basic-common" + (:variables + (sly-lisp-indent-maximum-backtracking 6) + (sly-lisp-tag-indentation 1) + (sly-lisp-tag-body-indentation 3) + (sly-lisp-backquote-indentation t) + (sly-lisp-loop-indent-subclauses t) + (sly-lisp-loop-indent-forms-like-keywords nil) + (sly-lisp-simple-loop-indentation 2) + (sly-lisp-align-keywords-in-calls t) + (sly-lisp-lambda-list-indentation t) + (sly-lisp-lambda-list-keyword-alignment nil) + (sly-lisp-lambda-list-keyword-parameter-indentation 2) + (sly-lisp-lambda-list-keyword-parameter-alignment nil) + (sly-lisp-indent-defun-method (4 &lambda &body)) + (sly-lisp-loop-clauses-indentation 2) + (sly-lisp-loop-indent-body-forms-relative-to-loop-start nil) + (sly-lisp-loop-body-forms-indentation 3))) + +(sly-define-common-lisp-style "basic-emacs25" + "This style adds a workaround needed for Emacs 25" + (:inherit "basic-common") + (:variables + ;; Without these (;;foo would get a space inserted between + ;; ( and ; by indent-sexp. + (comment-indent-function (lambda () nil)))) + +(sly-define-common-lisp-style "basic-emacs26" + "This style is the same as basic-common. It doesn't need or + want the workaround used in Emacs 25. In Emacs 26, that + workaround introduces a weird behavior where a single + semicolon breaks the mode and causes the cursor to move to the + start of the line after every character inserted." + (:inherit "basic-common")) + +(sly-define-common-lisp-style "basic" + "This style merely gives all identation variables their default values, + making it easy to create new styles that are proof against user + customizations. It also adjusts comment indentation from default. + All other predefined modes inherit from basic." + (:inherit (if (>= emacs-major-version 26) + "basic-emacs26" + "basic-emacs25"))) + +(sly-define-common-lisp-style "classic" + "This style of indentation emulates the most striking features of 1995 + vintage cl-indent.el once included as part of Slime: IF indented by two + spaces, and CASE clause bodies indentented more deeply than the keys." + (:inherit "basic") + (:variables + (sly-lisp-lambda-list-keyword-parameter-indentation 0)) + (:indentation + (case (4 &rest (&whole 2 &rest 3))) + (if (4 2 2)))) + +(sly-define-common-lisp-style "modern" + "A good general purpose style. Turns on lambda-list keyword and keyword + parameter alignment, and turns subclause aware loop indentation off. + (Loop indentation so because simpler style is more prevalent in existing + sources, not because it is necessarily preferred.)" + (:inherit "basic") + (:variables + (sly-lisp-lambda-list-keyword-alignment t) + (sly-lisp-lambda-list-keyword-parameter-alignment t) + (sly-lisp-lambda-list-keyword-parameter-indentation 0) + (sly-lisp-loop-indent-subclauses nil))) + +(sly-define-common-lisp-style "sbcl" + "Style used in SBCL sources. A good if somewhat intrusive general purpose + style based on the \"modern\" style. Adds indentation for a few SBCL + specific constructs, sets indentation to use spaces instead of tabs, + fill-column to 78, and activates whitespace-mode to show tabs and trailing + whitespace." + (:inherit "modern") + (:eval + (whitespace-mode 1)) + (:variables + (whitespace-style (tabs trailing)) + (indent-tabs-mode nil) + (comment-fill-column nil) + (fill-column 78)) + (:indentation + (def!constant (as defconstant)) + (def!macro (as defmacro)) + (def!method (as defmethod)) + (def!struct (as defstruct)) + (def!type (as deftype)) + (defmacro-mundanely (as defmacro)) + (deftransform (as defmacro)) + (define-source-transform (as defun)) + (!def-type-translator (as defun)) + (!def-debug-command (as defun)))) + +(defcustom sly-common-lisp-style-default nil + "Name of the Common Lisp indentation style to use in lisp-mode buffers if +none has been specified." + :type `(choice (const :tag "None" nil) + ,@(mapcar (lambda (spec) + `(const :tag ,(car spec) ,(car spec))) + (sly--lisp-indent-style-names)) + (string :tag "Other")) + :group 'sly-lisp-indent) + +;;; If style is being used, that's a sufficient invitation to snag +;;; the indentation function. +(defun sly--lisp-indent-lisp-mode-hook () + (let ((style (or sly-common-lisp-style + (bound-and-true-p common-lisp-style) + sly-common-lisp-style-default))) + (when style + (setq-local lisp-indent-function #'sly-common-lisp-indent-function) + (sly-common-lisp-set-style style)))) +(add-hook 'lisp-mode-hook #'sly--lisp-indent-lisp-mode-hook) + + +;;;; The indentation specs are stored at three levels. In order of priority: +;;;; +;;;; 1. Indentation as set by current style, from the indentation table +;;;; in the current style. +;;;; +;;;; 2. Globally set indentation, from the `sly-common-lisp-indent-function' +;;;; property of the symbol. +;;;; +;;;; 3. Per-package indentation derived by the system. A live Common Lisp +;;;; system may (via Slime, eg.) add indentation specs to +;;;; sly-common-lisp-system-indentation, where they are associated with +;;;; the package of the symbol. Then we run some lossy heuristics and +;;;; find something that looks promising. +;;;; +;;;; FIXME: for non-system packages the derived indentation should probably +;;;; take precedence. + +;;; This maps symbols into lists of (INDENT . PACKAGES) where INDENT is +;;; an indentation spec, and PACKAGES are the names of packages where this +;;; applies. +;;; +;;; We never add stuff here by ourselves: this is for things like Slime to +;;; fill. +(defvar sly-common-lisp-system-indentation (make-hash-table :test 'equal)) + +(defun sly--lisp-indent-guess-current-package () + (save-excursion + (ignore-errors + (when (let ((case-fold-search t)) + (search-backward "(in-package ")) + (re-search-forward "[ :\"]+") + (let ((start (point))) + (re-search-forward "[\":)]") + (upcase (buffer-substring-no-properties + start (1- (point))))))))) + +(defvar sly--lisp-indent-current-package-function + 'sly--lisp-indent-guess-current-package + "Used to derive the package name to use for indentation at a +given point. Defaults to `sly--lisp-indent-guess-current-package'.") + +(defun sly--lisp-indent-symbol-package (string) + (if (and (stringp string) (string-match ":" string)) + (let ((p (match-beginning 0))) + (if (eq p 0) + "KEYWORD" + (upcase (substring string 0 p)))) + (funcall sly--lisp-indent-current-package-function))) + +(defun sly--lisp-indent-get-indentation (name &optional full) + "Retrieves the indentation information for NAME." + (let ((method + (or + ;; From style + (let ((methods (sly--lisp-indent-active-style-methods))) + (and methods (gethash name methods))) + ;; From global settings. + (get name 'sly-common-lisp-indent-function) + (get name 'common-lisp-indent-function) + ;; From system derived information. + (let ((system-info (gethash name sly-common-lisp-system-indentation))) + (if (not (cdr system-info)) + (caar system-info) + (let ((guess nil) + (guess-n 0) + (package (sly--lisp-indent-symbol-package full))) + (cl-dolist (info system-info guess) + (let* ((pkgs (cdr info)) + (n (length pkgs))) + (cond ((member package pkgs) + ;; This is it. + (cl-return (car info))) + ((> n guess-n) + ;; If we can't find the real thing, go with the one + ;; accessible in most packages. + (setf guess (car info) + guess-n n))))))))))) + (if (eq 'as (car-safe method)) + (sly--lisp-indent-get-indentation (cadr method)) + method))) + +;;;; LOOP indentation, the simple version + +(defun sly--lisp-indent-loop-type (loop-start) + "Returns the type of the loop form at LOOP-START. +Possible types are SIMPLE, SIMPLE/SPLIT, EXTENDED, and EXTENDED/SPLIT. */SPLIT +refers to extended loops whose body does not start on the same line as the +opening parenthesis of the loop." + (let (comment-split) + (condition-case () + (save-excursion + (goto-char loop-start) + (let ((line (line-number-at-pos)) + (maybe-split t)) + (forward-char 1) + (forward-sexp 1) + (save-excursion + (when (looking-at "\\s-*\\\n*;") + (search-forward ";") + (backward-char 1) + (if (= line (line-number-at-pos)) + (setq maybe-split nil) + (setq comment-split t)))) + (forward-sexp 1) + (backward-sexp 1) + (if (eq (char-after) ?\() + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'simple + 'simple/split) + (if (or (not maybe-split) (= line (line-number-at-pos))) + 'extended + 'extended/split)))) + (error + (if comment-split + 'simple/split + 'simple))))) + +(defun sly--lisp-indent-trailing-comment () + (ignore-errors + ;; If we had a trailing comment just before this, find it. + (save-excursion + (backward-sexp) + (forward-sexp) + (when (looking-at "\\s-*;") + (search-forward ";") + (1- (current-column)))))) + +;;;###autoload +(defun sly-common-lisp-indent-function (indent-point state) + "Function to indent the arguments of a Lisp function call. +This is suitable for use as the value of the variable +`lisp-indent-function'. INDENT-POINT is the point at which the +indentation function is called, and STATE is the +`parse-partial-sexp' state at that position. Browse the +`sly-lisp-indent' customize group for options affecting the behavior +of this function. + +If the indentation point is in a call to a Lisp function, that +function's `sly-common-lisp-indent-function' property specifies how +this function should indent it. Possible values for this +property are: + +* defun, meaning indent according to + `sly-lisp-indent-defun-method'; i.e., like (4 &lambda &body), + as explained below. + +* any other symbol, meaning a function to call. The function + should take the arguments: PATH STATE INDENT-POINT SEXP-COLUMN + NORMAL-INDENT. PATH is a list of integers describing the + position of point in terms of list-structure with respect to + the containing lists. For example, in + ((a b c (d foo) f) g), foo has a path of (0 3 1). In other + words, to reach foo take the 0th element of the outermost list, + then the 3rd element of the next list, and finally the 1st + element. STATE and INDENT-POINT are as in the arguments to + `sly-common-lisp-indent-function'. SEXP-COLUMN is the column of + the open parenthesis of the innermost containing list. + NORMAL-INDENT is the column the indentation point was + originally in. This function should behave like + `sly--lisp-indent-259'. + +* an integer N, meaning indent the first N arguments like + function arguments, and any further arguments like a body. + This is equivalent to (4 4 ... &body). + +* a list starting with `as' specifies an indirection: indentation + is done as if the form being indented had started with the + second element of the list. + +* any other list. The list element in position M specifies how + to indent the Mth function argument. If there are fewer + elements than function arguments, the last list element applies + to all remaining arguments. The accepted list elements are: + + * nil, meaning the default indentation. + + * an integer, specifying an explicit indentation. + + * &lambda. Indent the argument (which may be a list) by 4. + + * &rest. When used, this must be the penultimate element. The + element after this one applies to all remaining arguments. + + * &body. This is equivalent to &rest lisp-body-indent, i.e., indent + all remaining elements by `lisp-body-indent'. + + * &whole. This must be followed by nil, an integer, or a + function symbol. This indentation is applied to the + associated argument, and as a base indent for all remaining + arguments. For example, an integer P means indent this + argument by P, and all remaining arguments by P, plus the + value specified by their associated list element. + + * a symbol. A function to call, with the 6 arguments specified above. + + * a list, with elements as described above. This applies when the + associated function argument is itself a list. Each element of the list + specifies how to indent the associated argument. + +For example, the function `case' has an indent property +\(4 &rest (&whole 2 &rest 1)), meaning: + * indent the first argument by 4. + * arguments after the first should be lists, and there may be any number + of them. The first list element has an offset of 2, all the rest + have an offset of 2+1=3." + (sly--lisp-indent-function-1 indent-point state)) + +(define-minor-mode sly-lisp-indent-compatibility-mode + "Replace the definition of `common-lisp-indent-function' with `sly-common-lisp-indent-function'. + +For backwards compatibility with the old sly-cl-indent.el, which +used to do this by default." + :group 'sly-lisp-indent + (if sly-lisp-indent-compatibility-mode + (advice-add 'common-lisp-indent-function + :override 'sly-common-lisp-indent-function) + (advice-remove 'common-lisp-indent-function + 'sly-common-lisp-indent-function))) + + +(defvar sly--lisp-indent-feature-expr-regexp "#!?\\(+\\|-\\)") + +;;; Semi-feature-expression aware keyword check. +(defun sly--lisp-indent-looking-at-keyword () + (or (looking-at ":") + (and (looking-at sly--lisp-indent-feature-expr-regexp) + (save-excursion + (forward-sexp) + (skip-chars-forward " \t\n") + (sly--lisp-indent-looking-at-keyword))))) + +;;; Semi-feature-expression aware backwards movement for keyword +;;; argument pairs. +(defun sly--lisp-indent-backward-keyword-argument () + (ignore-errors + (backward-sexp 2) + (when (looking-at sly--lisp-indent-feature-expr-regexp) + (cond ((ignore-errors + (save-excursion + (backward-sexp 2) + (looking-at sly--lisp-indent-feature-expr-regexp))) + (sly--lisp-indent-backward-keyword-argument)) + ((ignore-errors + (save-excursion + (backward-sexp 1) + (looking-at ":"))) + (backward-sexp)))) + t)) + +(defvar sly--lisp-indent-containing-sexp) + +(defun sly--lisp-indent-function-1 (indent-point state) + ;; If we're looking at a splice, move to the first comma. + (when (or (eq (char-before) ?,) + (and (eq (char-before) ?@) + (eq (char-before (1- (point))) ?,))) + (when (re-search-backward "[^,@'],") + (forward-char 1))) + (let ((normal-indent (current-column))) + ;; Walk up list levels until we see something + ;; which does special things with subforms. + (let ((depth 0) + ;; Path describes the position of point in terms of + ;; list-structure with respect to containing lists. + ;; `foo' has a path of (0 3 1) in `((a b c (d foo) f) g)'. + (path ()) + ;; set non-nil when somebody works out the indentation to use + calculated + ;; If non-nil, this is an indentation to use + ;; if nothing else specifies it more firmly. + tentative-calculated + ;; (last-point indent-point) + ;; the position of the open-paren of the innermost containing list + (containing-form-start (sly--lisp-indent-parse-state-start state)) + ;; the column of the above + sexp-column) + ;; Move to start of innermost containing list + (goto-char containing-form-start) + (setq sexp-column (current-column)) + + ;; Look over successively less-deep containing forms + (while (and (not calculated) + (< depth sly-lisp-indent-maximum-backtracking)) + (let ((sly--lisp-indent-containing-sexp (point))) + (forward-char 1) + (parse-partial-sexp (point) indent-point 1 t) + ;; Move to the car of the relevant containing form + (let (tem full function method tentative-defun) + (if (not (looking-at "\\sw\\|\\s_")) + ;; This form doesn't seem to start with a symbol + (setq function nil method nil full nil) + (setq tem (point)) + (forward-sexp 1) + (setq full (downcase (buffer-substring-no-properties tem (point))) + function full) + (goto-char tem) + (setq tem (intern-soft function) + method (sly--lisp-indent-get-indentation tem)) + (cond ((and (null method) + (string-match ":[^:]+" function)) + ;; The pleblisp package feature + (setq function (substring function (1+ (match-beginning 0))) + method (sly--lisp-indent-get-indentation + (intern-soft function) full))) + ((and (null method)) + ;; backwards compatibility + (setq method (sly--lisp-indent-get-indentation tem))))) + (let ((n 0)) + ;; How far into the containing form is the current form? + (if (< (point) indent-point) + (while (ignore-errors + (forward-sexp 1) + (if (>= (point) indent-point) + nil + (parse-partial-sexp (point) + indent-point 1 t) + (setq n (1+ n)) + t)))) + (setq path (cons n path))) + + ;; Guess. + (when (and (not method) function (null (cdr path))) + ;; (package prefix was stripped off above) + (cond ((and (string-match "\\`def" function) + (not (string-match "\\`default" function)) + (not (string-match "\\`definition" function)) + (not (string-match "\\`definer" function))) + (setq tentative-defun t)) + ((string-match + (eval-when-compile + (concat "\\`\\(" + (regexp-opt '("with" "without" "do")) + "\\)-")) + function) + (setq method '(&lambda &body))))) + + ;; #+ and #- cleverness. + (save-excursion + (goto-char indent-point) + (backward-sexp) + (let ((indent (current-column))) + (when + (or (looking-at sly--lisp-indent-feature-expr-regexp) + (ignore-errors + (backward-sexp) + (when (looking-at sly--lisp-indent-feature-expr-regexp) + (setq indent (current-column)) + (let ((line (line-number-at-pos))) + (while + (ignore-errors + (backward-sexp 2) + (and (= line (line-number-at-pos)) + (looking-at sly--lisp-indent-feature-expr-regexp))) + (setq indent (current-column)))) + t))) + (setq calculated (list indent containing-form-start))))) + + (cond ((and (or (eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\') + (and (not sly-lisp-backquote-indentation) + (eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\`))) + (not (eq (char-after (- sly--lisp-indent-containing-sexp 2)) ?\#))) + ;; No indentation for "'(...)" elements + (setq calculated (1+ sexp-column))) + ((eq (char-after (1- sly--lisp-indent-containing-sexp)) ?\#) + ;; "#(...)" + (setq calculated (1+ sexp-column))) + ((null method) + ;; If this looks like a call to a `def...' form, + ;; think about indenting it as one, but do it + ;; tentatively for cases like + ;; (flet ((defunp () + ;; nil))) + ;; Set both normal-indent and tentative-calculated. + ;; The latter ensures this value gets used + ;; if there are no relevant containing constructs. + ;; The former ensures this value gets used + ;; if there is a relevant containing construct + ;; but we are nested within the structure levels + ;; that it specifies indentation for. + (if tentative-defun + (setq tentative-calculated + (sly--lisp-indent-call-method + function sly-lisp-indent-defun-method + path state indent-point + sexp-column normal-indent) + normal-indent tentative-calculated) + (when sly-lisp-align-keywords-in-calls + ;; No method so far. If we're looking at a keyword, + ;; align with the first keyword in this expression. + ;; This gives a reasonable indentation to most things + ;; with keyword arguments. + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (when (sly--lisp-indent-looking-at-keyword) + (while (sly--lisp-indent-backward-keyword-argument) + (when (sly--lisp-indent-looking-at-keyword) + (setq calculated + (list (current-column) + containing-form-start))))))))) + ((integerp method) + ;; convenient top-level hack. + ;; (also compatible with lisp-indent-function) + ;; The number specifies how many `distinguished' + ;; forms there are before the body starts + ;; Equivalent to (4 4 ... &body) + (setq calculated (cond ((cdr path) normal-indent) + ((<= (car path) method) + ;; `distinguished' form + (list (+ sexp-column 4) + containing-form-start)) + ((= (car path) (1+ method)) + ;; first body form. + (+ sexp-column lisp-body-indent)) + (t + ;; other body form + normal-indent)))) + (t + (setq calculated + (sly--lisp-indent-call-method + function method path state indent-point + sexp-column normal-indent))))) + (goto-char sly--lisp-indent-containing-sexp) + ;; (setq last-point sly--lisp-indent-containing-sexp) + (unless calculated + (condition-case () + (progn (backward-up-list 1) + (setq depth (1+ depth))) + (error + (setq depth sly-lisp-indent-maximum-backtracking)))))) + + (or calculated tentative-calculated + ;; Fallback. + ;; + ;; Instead of punting directly to calculate-lisp-indent we + ;; handle a few of cases it doesn't deal with: + ;; + ;; A: (foo ( + ;; bar zot + ;; quux)) + ;; + ;; would align QUUX with ZOT. + ;; + ;; B: + ;; (foo (or x + ;; y) t + ;; z) + ;; + ;; would align the Z with Y. + ;; + ;; C: + ;; (foo ;; Comment + ;; (bar) + ;; ;; Comment 2 + ;; (quux)) + ;; + ;; would indent BAR and QUUX by one. + (ignore-errors + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (let ((p (point))) + (goto-char containing-form-start) + (down-list) + (let ((one (current-column))) + (skip-chars-forward " \t") + (if (or (eolp) (looking-at ";")) + ;; A. + (list one containing-form-start) + (forward-sexp 2) + (backward-sexp) + (if (/= p (point)) + ;; B. + (list (current-column) containing-form-start) + (backward-sexp) + (forward-sexp) + (let ((tmp (+ (current-column) 1))) + (skip-chars-forward " \t") + (if (looking-at ";") + ;; C. + (list tmp containing-form-start))))))))))))) + + + +;; Dynamically bound in `sly--lisp-indent-call-method'. +(defvar sly--lisp-indent-error-function) + +(defun sly--lisp-indent-call-method (function method path state indent-point + sexp-column normal-indent) + (let ((sly--lisp-indent-error-function function)) + (if (symbolp method) + (funcall method + path state indent-point + sexp-column normal-indent) + (sly--lisp-indent-259 method path state indent-point + sexp-column normal-indent)))) + +(defun sly--lisp-indent-report-bad-format (m) + (error "%s has a badly-formed %s property: %s" + ;; Love those free variable references!! + sly--lisp-indent-error-function + 'sly-common-lisp-indent-function m)) + + +;; Lambda-list indentation is now done in `sly--lisp-indent-lambda-list'. +;; See also `sly-lisp-lambda-list-keyword-alignment', +;; `sly-lisp-lambda-list-keyword-parameter-alignment' and +;; `sly-lisp-lambda-list-keyword-parameter-indentation' -- dvl + +(defvar sly--lisp-indent-lambda-list-keywords-regexp + "&\\(\ +optional\\|rest\\|key\\|allow-other-keys\\|aux\\|whole\\|body\\|\ +environment\\|more\ +\\)\\>" + "Regular expression matching lambda-list keywords.") + +(defun sly--lisp-indent-lambda-list + (indent-point sexp-column containing-form-start) + (if (not sly-lisp-lambda-list-indentation) + (1+ sexp-column) + (sly--lisp-indent-properly-indent-lambda-list + indent-point sexp-column containing-form-start))) + +(defun sly--lisp-indent-properly-indent-lambda-list + (indent-point sexp-column containing-form-start) + (cond + ((save-excursion + (goto-char indent-point) + (back-to-indentation) + (looking-at sly--lisp-indent-lambda-list-keywords-regexp)) + ;; We're facing a lambda-list keyword. + (if sly-lisp-lambda-list-keyword-alignment + ;; Align to the first keyword if any, or to the beginning of + ;; the lambda-list. + (save-excursion + (goto-char containing-form-start) + (down-list) + (let ((key-indent nil) + (next t)) + (while (and next (< (point) indent-point)) + (if (looking-at sly--lisp-indent-lambda-list-keywords-regexp) + (setq key-indent (current-column) + next nil) + (setq next (ignore-errors (forward-sexp) t)) + (if next + (ignore-errors + (forward-sexp) + (backward-sexp))))) + (or key-indent + (1+ sexp-column)))) + ;; Align to the beginning of the lambda-list. + (1+ sexp-column))) + (t + ;; Otherwise, align to the first argument of the last lambda-list + ;; keyword, the keyword itself, or the beginning of the + ;; lambda-list. + (save-excursion + (goto-char indent-point) + (let ((indent nil) + (next t)) + (while (and next (> (point) containing-form-start)) + (setq next (ignore-errors (backward-sexp) t)) + (let* ((col (current-column)) + (pos + (save-excursion + (ignore-errors (forward-sexp)) + (skip-chars-forward " \t") + (if (eolp) + (+ col sly-lisp-lambda-list-keyword-parameter-indentation) + col)))) + (if (looking-at sly--lisp-indent-lambda-list-keywords-regexp) + (setq indent + (if sly-lisp-lambda-list-keyword-parameter-alignment + (or indent pos) + (+ col sly-lisp-lambda-list-keyword-parameter-indentation)) + next nil) + (setq indent col)))) + (or indent (1+ sexp-column))))))) + +(defun sly--lisp-indent-lambda-list-initial-value-form-p (point) + (let ((state 'x) + (point (save-excursion + (goto-char point) + (back-to-indentation) + (point)))) + (save-excursion + (backward-sexp) + (ignore-errors (down-list 1)) + (while (and point (< (point) point)) + (cond ((looking-at "&\\(key\\|optional\\|aux\\)") + (setq state 'key)) + ((looking-at sly--lisp-indent-lambda-list-keywords-regexp) + (setq state 'x))) + (if (not (ignore-errors (forward-sexp) t)) + (setq point nil) + (ignore-errors + (forward-sexp) + (backward-sexp)) + (cond ((> (point) point) + (backward-sexp) + (when (eq state 'var) + (setq state 'x)) + (or (ignore-errors + (down-list 1) + (cond ((> (point) point) + (backward-up-list)) + ((eq 'key state) + (setq state 'var))) + t) + (setq point nil))) + ((eq state 'var) + (setq state 'form)))))) + (eq 'form state))) + +;; Blame the crufty control structure on dynamic scoping +;; -- not on me! +(defun sly--lisp-indent-259 + (method path state indent-point sexp-column normal-indent) + (catch 'exit + (let* ((p (cdr path)) + (containing-form-start (elt state 1)) + (n (1- (car path))) + tem tail) + (if (not (consp method)) + (sly--lisp-indent-report-bad-format method)) + (while n + ;; This while loop is for advancing along a method + ;; until the relevant (possibly &rest/&body) pattern + ;; is reached. + ;; n is set to (1- n) and method to (cdr method) + ;; each iteration. + (setq tem (car method)) + + (or (eq tem 'nil) ;default indentation + (eq tem '&lambda) ;lambda list + (and (eq tem '&body) (null (cdr method))) + (and (eq tem '&rest) + (consp (cdr method)) + (null (cddr method))) + (integerp tem) ;explicit indentation specified + (and (consp tem) ;destructuring + (or (consp (car tem)) + (and (eq (car tem) '&whole) + (or (symbolp (cadr tem)) + (integerp (cadr tem)))))) + (and (symbolp tem) ;a function to call to do the work. + (null (cdr method))) + (sly--lisp-indent-report-bad-format method)) + (cond ((eq tem '&body) + ;; &body means (&rest ) + (throw 'exit + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent))) + ((eq tem '&rest) + ;; this pattern holds for all remaining forms + (setq tail (> n 0) + n 0 + method (cdr method))) + ((> n 0) + ;; try next element of pattern + (setq n (1- n) + method (cdr method)) + (if (< n 0) + ;; Too few elements in pattern. + (throw 'exit normal-indent))) + ((eq tem 'nil) + (throw 'exit (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start)))) + ((eq tem '&lambda) + (throw 'exit + (cond ((not (eq (char-before) ?\))) + ;; If it's not a list at all, indent it + ;; like body instead. + (if (null p) + (+ sexp-column lisp-body-indent) + normal-indent)) + ((sly--lisp-indent-lambda-list-initial-value-form-p indent-point) + (if (consp normal-indent) + normal-indent + (list normal-indent containing-form-start))) + ((null p) + (list (+ sexp-column 4) containing-form-start)) + (t + ;; Indentation within a lambda-list. -- dvl + (list (sly--lisp-indent-lambda-list + indent-point + sexp-column + containing-form-start) + containing-form-start))))) + ((integerp tem) + (throw 'exit + (if (null p) ;not in subforms + (list (+ sexp-column tem) containing-form-start) + normal-indent))) + ((symbolp tem) ;a function to call + (throw 'exit + (funcall tem path state indent-point + sexp-column normal-indent))) + (t + ;; must be a destructing frob + (if p + ;; descend + (setq method (cddr tem) + n (car p) + p (cdr p) + tail nil) + (let ((wholep (eq '&whole (car tem)))) + (setq tem (cadr tem)) + (throw 'exit + (cond (tail + (if (and wholep (integerp tem) + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (looking-at "\\sw"))) + ;; There's a further level of + ;; destructuring, but we're looking at a + ;; word -- indent to sexp. + (+ sexp-column tem) + normal-indent)) + ((not tem) + (list normal-indent + containing-form-start)) + ((integerp tem) + (list (+ sexp-column tem) + containing-form-start)) + (t + (funcall tem path state indent-point + sexp-column normal-indent)))))))))))) + +(defun sly--lisp-indent-tagbody (path state indent-point sexp-column normal-indent) + (if (cdr path) + normal-indent + (save-excursion + (goto-char indent-point) + (back-to-indentation) + (list (cond ((looking-at "\\sw\\|\\s_") + ;; a tagbody tag + (+ sexp-column sly-lisp-tag-indentation)) + ((integerp sly-lisp-tag-body-indentation) + (+ sexp-column sly-lisp-tag-body-indentation)) + ((eq sly-lisp-tag-body-indentation 't) + (condition-case () + (progn (backward-sexp 1) (current-column)) + (error (1+ sexp-column)))) + (t (+ sexp-column lisp-body-indent))) + (nth 1 state))))) + +(defun sly--lisp-indent-do (path state indent-point sexp-column normal-indent) + (if (>= (car path) 3) + (let ((sly-lisp-tag-body-indentation lisp-body-indent)) + (sly--lisp-indent-tagbody + path state indent-point sexp-column normal-indent)) + (sly--lisp-indent-259 + '((&whole nil &rest + ;; the following causes weird indentation + ;;(&whole 1 1 2 nil) + ) + (&whole nil &rest 1)) + path state indent-point sexp-column normal-indent))) + +(defun sly--lisp-indent-defsetf + (path state indent-point sexp-column normal-indent) + (ignore normal-indent) + (let ((form-start (nth 1 state))) + (list + (cond + ;; Inside the lambda-list in a long-form defsetf. + ((and (eq 2 (car path)) (cdr path)) + (sly--lisp-indent-lambda-list indent-point sexp-column form-start)) + ;; Long form: has a lambda-list. + ((or (cdr path) + (save-excursion + (goto-char form-start) + (ignore-errors + (down-list) + (forward-sexp 3) + (backward-sexp) + (looking-at "nil\\|(")))) + (+ sexp-column (if (<= 1 (car path) 3) 4 2))) + ;; Short form. + (t (+ sexp-column (if (<= 1 (car path) 2) 4 2)))) + form-start))) + +(defun sly--lisp-indent-beginning-of-defmethod-qualifiers () + (let ((case-fold-search t) + (regexp "(\\(?:\\(def\\)\\|\\(:\\)\\)method")) + (ignore-errors + (while (not (looking-at regexp)) (backward-up-list)) + (cond ((match-string 1) + (forward-char) + ;; Skip name. + (forward-sexp 2) + 1) + ((match-string 2) + (forward-char) + (forward-sexp 1) + 0))))) + +;; LISP-INDENT-DEFMETHOD now supports the presence of more than one method +;; qualifier and indents the method's lambda list properly. -- dvl +(defun sly--lisp-indent-defmethod + (path state indent-point sexp-column normal-indent) + (sly--lisp-indent-259 + (let ((nskip nil)) + (if (save-excursion + (when (setq nskip (sly--lisp-indent-beginning-of-defmethod-qualifiers)) + (skip-chars-forward " \t\n") + (while (looking-at "\\sw\\|\\s_") + (cl-incf nskip) + (forward-sexp) + (skip-chars-forward " \t\n")) + t)) + (nconc (make-list nskip 4) '(&lambda &body)) + (sly--lisp-indent-get-indentation 'defun))) + path state indent-point sexp-column normal-indent)) + +(defun sly--lisp-indent-function-lambda-hack (path state indent-point + sexp-column normal-indent) + (ignore indent-point state) + ;; indent (function (lambda () )) kludgily. + (if (or (cdr path) ; wtf? + (> (car path) 3)) + ;; line up under previous body form + normal-indent + ;; line up under function rather than under lambda in order to + ;; conserve horizontal space. (Which is what #' is for.) + (condition-case () + (save-excursion + (backward-up-list 2) + (forward-char 1) + (if (looking-at "\\(\\(common-lisp\\|cl\\)::?\\)?function\\(\\Sw\\|\\S_\\)") + (+ lisp-body-indent -1 (current-column)) + (+ sexp-column lisp-body-indent))) + (error (+ sexp-column lisp-body-indent))))) + +(defun sly--lisp-indent-loop (path state indent-point sexp-column normal-indent) + (ignore sexp-column) + (if (cdr path) + normal-indent + (let* ((loop-start (elt state 1)) + (type (sly--lisp-indent-loop-type loop-start))) + (cond ((and sly-lisp-loop-indent-subclauses + (memq type '(extended extended/split))) + (list (sly--lisp-indent-loop-macro-1 state indent-point) + (sly--lisp-indent-parse-state-start state))) + (t + (sly--lisp-indent-loop-part-indentation indent-point state type)))))) + +;;;; LOOP indentation, the complex version -- handles subclause indentation + +;; Regexps matching various varieties of loop macro keyword ... +(defvar sly--common-lisp-body-introducing-loop-macro-keyword + (concat "\\(?:\\_<\\|#?:\\)" + (regexp-opt '("do" "doing" "finally" "initially")) + "\\_>") + "Regexp matching loop macro keywords which introduce body forms.") + +;; Not currently used +(defvar sly--common-lisp-accumulation-loop-macro-keyword + (concat "\\(?:\\_<\\|#?:\\)" + (regexp-opt '("collect" "collecting" + "append" "appending" + "nconc" "nconcing" + "sum" "summing" + "count" "counting" + "maximize" "maximizing" + "minimize" "minimizing")) + "\\_>") + "Regexp matching loop macro keywords which introduce accumulation clauses.") + +;; This is so "and when" and "else when" get handled right +;; (not to mention "else do" !!!) +(defvar sly--common-lisp-prefix-loop-macro-keyword + (concat "\\(?:\\_<\\|#?:\\)" (regexp-opt '("and" "else")) "\\_>") + "Regexp matching loop macro keywords which are prefixes.") + +(defvar sly--common-lisp-indent-clause-joining-loop-macro-keyword + "\\(?:\\_<\\|#?:\\)and\\_>" + "Regexp matching 'and', and anything else there ever comes to be like it.") + +(defvar sly--common-lisp-indent-indented-loop-macro-keyword + (concat "\\(?:\\_<\\|#?:\\)" + (regexp-opt '("upfrom" "downfrom" "upto" "downto" "below" "above" + "into" "in" "on" "by" "from" "to" "by" "across" "being" + "each" "the" "then" "hash-key" "hash-keys" "hash-value" + "hash-values" "present-symbol" "present-symbols" + "external-symbol" "external-symbols" "using" "symbol" + "symbols" "float" "fixnum" "t" "nil" "of-type" "of" "=")) + "\\_>") + "Regexp matching keywords introducing loop subclauses. +Always indented two.") + +(defvar sly--common-lisp-indenting-loop-macro-keyword + (concat "\\(?:\\_<\\|#?:\\)" (regexp-opt '("when" "unless" "if")) "\\_>") + "Regexp matching keywords introducing conditional clauses. +Cause subsequent clauses to be indented.") + +(defvar sly--lisp-indent-loop-macro-else-keyword + "\\(?:\\_<\\|#?:\\)else\\_>") + +;;; Attempt to indent the loop macro ... +(defun sly--lisp-indent-loop-part-indentation (indent-point state type) + "Compute the indentation of loop form constituents." + (let* ((loop-start (nth 1 state)) + (loop-indentation (save-excursion + (goto-char loop-start) + (if (eq type 'extended/split) + (- (current-column) 4) + (current-column)))) + (indent nil) + (re "\\(\\(#?:\\)?\\sw+\\|)\\|\n\\)")) + (goto-char indent-point) + (back-to-indentation) + (cond ((eq type 'simple/split) + (+ loop-indentation sly-lisp-simple-loop-indentation)) + ((eq type 'simple) + (+ loop-indentation 6)) + ;; We are already in a body, with forms in it. + ((and (not (looking-at re)) + (save-excursion + (while (and (ignore-errors (backward-sexp) t) + (not (looking-at re))) + (setq indent (current-column))) + (and indent + (looking-at sly--common-lisp-body-introducing-loop-macro-keyword)))) + (list indent loop-start)) + ;; Keyword-style or comment outside body + ((or sly-lisp-loop-indent-forms-like-keywords + (looking-at re) + (looking-at ";")) + (if (and (looking-at ";") + (let ((p (sly--lisp-indent-trailing-comment))) + (when p + (setq loop-indentation p)))) + (list loop-indentation loop-start) + (list (+ loop-indentation 6) loop-start))) + ;; Form-style + (t + (list (+ loop-indentation 9) loop-start))))) + +(defun sly--lisp-indent-loop-advance-past-keyword-on-line () + (forward-word 1) + (while (and (looking-at "\\s-") (not (eolp))) + (forward-char 1)) + (unless (eolp) + (current-column))) + +(defun sly--lisp-indent-loop-macro-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of loop macro, and use it to establish + ;; base column for indentation + (goto-char (sly--lisp-indent-parse-state-start parse-state)) + (let ((loop-start-column (current-column))) + (sly--lisp-indent-loop-advance-past-keyword-on-line) + + (when (eolp) + (forward-line 1) + (end-of-line) + ;; If indenting first line after "(loop " + ;; cop out ... + (if (<= indent-point (point)) + (throw 'return-indentation + (+ loop-start-column + sly-lisp-loop-clauses-indentation))) + (back-to-indentation)) + + (let* ((case-fold-search t) + (loop-macro-first-clause (point)) + (previous-expression-start + (sly--lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (loop-body-p nil) + (loop-body-indentation nil) + (indented-clause-indentation (+ 2 default-value))) + ;; Determine context of this loop clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + + ;; Handle a body-introducing-clause which ends a line specially. + (if (looking-at sly--common-lisp-body-introducing-loop-macro-keyword) + (let ((keyword-position (current-column))) + (setq loop-body-p t) + (setq loop-body-indentation + (if (sly--lisp-indent-loop-advance-past-keyword-on-line) + (current-column) + (back-to-indentation) + (if (/= (current-column) keyword-position) + (+ 2 (current-column)) + (+ sly-lisp-loop-body-forms-indentation + (if sly-lisp-loop-indent-body-forms-relative-to-loop-start + loop-start-column + keyword-position)))))) + + (back-to-indentation) + (if (< (point) loop-macro-first-clause) + (goto-char loop-macro-first-clause)) + ;; If there's an "and" or "else," advance over it. + ;; If it is alone on the line, the next "cond" will treat it + ;; as if there were a "when" and indent under it ... + (let ((exit nil)) + (while (and (null exit) + (looking-at sly--common-lisp-prefix-loop-macro-keyword)) + (if (null (sly--lisp-indent-loop-advance-past-keyword-on-line)) + (progn (setq exit t) + (back-to-indentation))))) + + ;; Found start of loop clause preceding the one we're + ;; trying to indent. Glean context ... + (cond + ((looking-at "(") + ;; We're in the middle of a clause body ... + (setq loop-body-p t) + (setq loop-body-indentation (current-column))) + ((looking-at sly--common-lisp-body-introducing-loop-macro-keyword) + (setq loop-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (sly--lisp-indent-loop-advance-past-keyword-on-line) + (setq loop-body-indentation (current-column))) + (t + (setq loop-body-p nil) + (if (or (looking-at sly--common-lisp-indenting-loop-macro-keyword) + (looking-at sly--common-lisp-prefix-loop-macro-keyword)) + (setq default-value (+ 2 (current-column)))) + (setq indented-clause-indentation (+ 2 (current-column))) + ;; We still need loop-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq loop-body-indentation (current-column))))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((looking-at "(") + ;; Clause body ... + loop-body-indentation) + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if loop-body-p + loop-body-indentation + (or (and (looking-at ";") (sly--lisp-indent-trailing-comment)) + default-value))) + ((looking-at sly--common-lisp-indent-indented-loop-macro-keyword) + indented-clause-indentation) + ((looking-at sly--common-lisp-indent-clause-joining-loop-macro-keyword) + (let ((stolen-indent-column nil)) + (forward-line -1) + (while (and (null stolen-indent-column) + (> (point) loop-macro-first-clause)) + (back-to-indentation) + (if (and (< (current-column) loop-body-indentation) + (looking-at "\\(#?:\\)?\\sw")) + (progn + (if (looking-at sly--lisp-indent-loop-macro-else-keyword) + (sly--lisp-indent-loop-advance-past-keyword-on-line)) + (setq stolen-indent-column (current-column))) + (forward-line -1))) + (or stolen-indent-column default-value))) + (t default-value))))))) + +(defalias 'sly--lisp-indent-if*-advance-past-keyword-on-line + #'sly--lisp-indent-loop-advance-past-keyword-on-line) + +;;;; IF* is not standard, but a plague upon the land +;;;; ...let's at least try to indent it. + +(defvar sly--lisp-indent-if*-keyword + "thenret\\|elseif\\|then\\|else" + "Regexp matching if* keywords") + +(defun sly--lisp-indent-if* + (path parse-state indent-point sexp-column normal-indent) + (ignore normal-indent path sexp-column) + (list (sly--lisp-indent-if*-1 parse-state indent-point) + (sly--lisp-indent-parse-state-start parse-state))) + +(defun sly--lisp-indent-if*-1 (parse-state indent-point) + (catch 'return-indentation + (save-excursion + ;; Find first clause of if* macro, and use it to establish + ;; base column for indentation + (goto-char (sly--lisp-indent-parse-state-start parse-state)) + (let ((if*-start-column (current-column))) + (sly--lisp-indent-if*-advance-past-keyword-on-line) + (let* ((case-fold-search t) + (if*-first-clause (point)) + (previous-expression-start + (sly--lisp-indent-parse-state-prev parse-state)) + (default-value (current-column)) + (if*-body-p nil) + (if*-body-indentation nil)) + ;; Determine context of this if* clause, starting with the + ;; expression immediately preceding the line we're trying to indent + (goto-char previous-expression-start) + ;; Handle a body-introducing-clause which ends a line specially. + (back-to-indentation) + (if (< (point) if*-first-clause) + (goto-char if*-first-clause)) + ;; Found start of if* clause preceding the one we're trying + ;; to indent. Glean context ... + (cond + ((looking-at sly--lisp-indent-if*-keyword) + (setq if*-body-p t) + ;; Know there's something else on the line (or would + ;; have been caught above) + (sly--lisp-indent-if*-advance-past-keyword-on-line) + (setq if*-body-indentation (current-column))) + ((looking-at "#'\\|'\\|(") + ;; We're in the middle of a clause body ... + (setq if*-body-p t) + (setq if*-body-indentation (current-column))) + (t + (setq if*-body-p nil) + ;; We still need if*-body-indentation for "syntax errors" ... + (goto-char previous-expression-start) + (setq if*-body-indentation (current-column)))) + + ;; Go to first non-blank character of the line we're trying + ;; to indent. (if none, wind up poised on the new-line ...) + (goto-char indent-point) + (back-to-indentation) + (cond + ((or (eolp) (looking-at ";")) + ;; Blank line. If body-p, indent as body, else indent as + ;; vanilla clause. + (if if*-body-p + if*-body-indentation + default-value)) + ((not (looking-at sly--lisp-indent-if*-keyword)) + ;; Clause body ... + if*-body-indentation) + (t (- (+ 7 if*-start-column) + (- (match-end 0) (match-beginning 0)))))))))) + + +;;;; Indentation specs for standard symbols, and a few semistandard ones. +(defun sly--lisp-indent-init-standard-indentation () + (let ((l '((block 1) + (case (4 &rest (&whole 2 &rest 1))) + (ccase (as case)) + (ecase (as case)) + (typecase (as case)) + (etypecase (as case)) + (ctypecase (as case)) + (catch 1) + (cond (&rest (&whole 2 &rest nil))) + ;; for DEFSTRUCT + (:constructor (4 &lambda)) + (defvar (4 2 2)) + (defclass (6 (&whole 4 &rest 1) + (&whole 2 &rest 1) + (&whole 2 &rest 1))) + (defconstant (as defvar)) + (defcustom (4 2 2 2)) + (defparameter (as defvar)) + (defconst (as defcustom)) + (define-condition (as defclass)) + (define-modify-macro (4 &lambda &body)) + (defsetf sly--lisp-indent-defsetf) + (defun (4 &lambda &body)) + (defgeneric (4 &lambda &body)) + (define-setf-method (as defun)) + (define-setf-expander (as defun)) + (defmacro (as defun)) + (defsubst (as defun)) + (deftype (as defun)) + (defmethod sly--lisp-indent-defmethod) + (defpackage (4 2)) + (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) + &rest (&whole 2 &rest 1))) + (destructuring-bind (&lambda 4 &body)) + (do sly--lisp-indent-do) + (do* (as do)) + (dolist ((&whole 4 2 1) &body)) + (dotimes (as dolist)) + (eval-when 1) + (flet ((&whole 4 &rest (&whole 1 4 &lambda &body)) &body)) + (labels (as flet)) + (macrolet (as flet)) + (generic-flet (as flet)) + (generic-labels (as flet)) + (handler-case (4 &rest (&whole 2 &lambda &body))) + (restart-case (as handler-case)) + ;; single-else style (then and else equally indented) + (if (&rest nil)) + (if* sly--lisp-indent-if*) + (lambda (&lambda &rest sly--lisp-indent-function-lambda-hack)) + (let ((&whole 4 &rest (&whole 1 1 2)) &body)) + (let* (as let)) + (compiler-let (as let)) + (handler-bind (as let)) + (restart-bind (as let)) + (locally 1) + (loop sly--lisp-indent-loop) + (:method sly--lisp-indent-defmethod) ; in `defgeneric' + (multiple-value-bind ((&whole 6 &rest 1) 4 &body)) + (multiple-value-call (4 &body)) + (multiple-value-prog1 1) + (multiple-value-setq (4 2)) + (multiple-value-setf (as multiple-value-setq)) + (named-lambda (4 &lambda &rest sly--lisp-indent-function-lambda-hack)) + (pprint-logical-block (4 2)) + (print-unreadable-object ((&whole 4 1 &rest 1) &body)) + ;; Combines the worst features of BLOCK, LET and TAGBODY + (prog (&lambda &rest sly--lisp-indent-tagbody)) + (prog* (as prog)) + (prog1 1) + (prog2 2) + (progn 0) + (progv (4 4 &body)) + (return 0) + (return-from (nil &body)) + (symbol-macrolet (as let)) + (tagbody sly--lisp-indent-tagbody) + (throw 1) + (unless 1) + (unwind-protect (5 &body)) + (when 1) + (with-slots (as multiple-value-bind)) + (with-accessors (as multiple-value-bind)) + (with-condition-restarts (as multiple-value-bind)) + (with-compilation-unit ((&whole 4 &rest 1) &body)) + (with-output-to-string (4 2)) + (with-standard-io-syntax (2))))) + (dolist (el l) + (let* ((name (car el)) + (indentation (cadr el))) + (put name 'sly-common-lisp-indent-function indentation))))) + +(sly--lisp-indent-init-standard-indentation) + +(provide 'sly-cl-indent) + +;;; sly-cl-indent.el ends here blob - /dev/null blob + c95f7666b3d2a5e835a10cf7e07eda2bd0541c89 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-common.el @@ -0,0 +1,76 @@ +;;; sly-common.el --- common utils for SLY and its contribs -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 João Távora + +;; Author: João Távora +;; Keywords: + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Common utilities for SLY and its contribs + +;;; Code: +(require 'cl-lib) + +(defun sly--call-refreshing (buffer + overlay + dont-erase + recover-point-p + flash-p + fn) + (with-current-buffer buffer + (let ((inhibit-point-motion-hooks t) + (inhibit-read-only t) + (saved (point))) + (save-restriction + (when overlay + (narrow-to-region (overlay-start overlay) + (overlay-end overlay))) + (unwind-protect + (if dont-erase + (goto-char (point-max)) + (delete-region (point-min) (point-max))) + (funcall fn) + (when recover-point-p + (goto-char saved))) + (when flash-p + (sly-flash-region (point-min) (point-max))))) + buffer)) + +(cl-defmacro sly-refreshing ((&key + overlay + dont-erase + (recover-point-p t) + flash-p + buffer) + &rest body) + "Delete a buffer region and run BODY which presumably refreshes it. +Region is OVERLAY or the whole buffer. +Recover point position if RECOVER-POINT-P. +Flash the resulting region if FLASH-P" + (declare (indent 1) + (debug (sexp &rest form))) + `(sly--call-refreshing ,(or buffer + `(current-buffer)) + ,overlay + ,dont-erase + ,recover-point-p + ,flash-p + #'(lambda () ,@body))) + + +(provide 'sly-common) +;;; sly-common.el ends here blob - /dev/null blob + 561b01cd1330148f05db5c156457d751bd0273e2 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-completion.el @@ -0,0 +1,806 @@ +;;; sly-completion.el --- completion tricks and helpers -*- lexical-binding: t; -*- + +;; Copyright (C) 2016 João Távora + +;; Author: João Távora +;; Keywords: + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: +;;; +(require 'cl-lib) +(require 'comint) +(require 'subr-x) +(require 'sly-messages "lib/sly-messages") + + +;;; Something to move to minibuffer.el, maybe + +;;; Backend completion + +;; This predates Emacs's 29's external-completion.el, generally +;; the same idea. Maybe use that some day + +(add-to-list 'completion-styles-alist + '(sly--external-completion + sly--external-tryc + sly--external-allc + "Ad-hoc \"external completion\" style (SLY flavor)")) + +(defun sly--external-allc (string table pred _point) + "Like `completion-all-completions', ask table for all completions." + (funcall table string pred t)) + +(defun sly--external-tryc (pat table pred point) + "Like `completion-try-completions', but knowing how SLY works." + (let* ((all (funcall table pat pred t)) ; invoke all-completions! + (probe (car all))) + (cond ((and probe (null (cdr all))) + (if (string= pat probe) + t + (cons probe (length probe)))) + (t (cons pat point))))) + + +;;; Forward declarations (later replace with a `sly-common' lib) +;;; +(defvar sly-current-thread) + +(declare-function sly-eval "sly" (sexp &optional package + cancel-on-input + cancel-on-input-retval)) + +(declare-function sly-symbol-at-point "sly") + +(declare-function sly-buffer-name "sly") + +(defvar sly-buffer-package) + +(defvar sly-buffer-connection) + +(declare-function sly-connection "sly") + +(declare-function sly-recenter "sly") + +(declare-function sly-symbol-start-pos "sly") + +(declare-function sly-symbol-end-pos "sly") + +(declare-function sly-current-package "sly") + +(declare-function with-displayed-buffer-window "window") + + +;;; Backward compatibility shim for emacs < 25. +;;; +(eval-when-compile + (unless (fboundp 'with-displayed-buffer-window) + (defmacro with-displayed-buffer-window (buffer-or-name action quit-function &rest body) + "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. +This construct is like `with-current-buffer-window' but unlike that +displays the buffer specified by BUFFER-OR-NAME before running BODY." + (declare (debug t)) + (let ((buffer (make-symbol "buffer")) + (window (make-symbol "window")) + (value (make-symbol "value"))) + (macroexp-let2 nil vbuffer-or-name buffer-or-name + (macroexp-let2 nil vaction action + (macroexp-let2 nil vquit-function quit-function + `(let* ((,buffer (temp-buffer-window-setup ,vbuffer-or-name)) + (standard-output ,buffer) + ,window ,value) + (with-current-buffer ,buffer + (setq ,window (temp-buffer-window-show + ,buffer + ;; Remove window-height when it's handled below. + (if (functionp (cdr (assq 'window-height (cdr ,vaction)))) + (assq-delete-all 'window-height (copy-sequence ,vaction)) + ,vaction)))) + + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (setq ,value (progn ,@body))) + + (set-window-point ,window (point-min)) + + (when (functionp (cdr (assq 'window-height (cdr ,vaction)))) + (ignore-errors + (funcall (cdr (assq 'window-height (cdr ,vaction))) ,window))) + + (if (functionp ,vquit-function) + (funcall ,vquit-function ,window ,value) + ,value))))))))) + + + +;;; Customization +;;; +(defcustom sly-complete-symbol-function 'sly-flex-completions + "Function reponsible for SLY completion. +When called with one argument, a pattern, returns a (possibly +propertized) list of strings the complete that pattern, +collected from the Slynk server." + :type 'function + :group 'sly-ui) + + +(cl-defmacro sly--responsive-eval ((var sexp + &optional + package + input-arrived-retval) &rest body) + "Use `sly-eval' on SEXP, PACKAGE, bind to VAR, run BODY. +If user input arrives in the meantime return INPUT-ARRIVED-RETVAL +immediately." + (declare (indent 1) (debug (sexp &rest form))) + (let ((sym (make-symbol "sly--responsive-eval"))) + `(let* ((,sym (make-symbol "sly--responsive-eval-unique")) + (,var (sly-eval ,sexp ,package non-essential ,sym))) + (if (eq ,var ,sym) + ,input-arrived-retval + ,@body)))) + + +;;; Completion calculation +;;; +(defun sly--completion-request-completions (pattern slyfun) + "Request completions for PATTERN using SLYFUN. +SLYFUN takes two arguments, a pattern and a package." + (when (sly-connected-p) + (let* ((sly-current-thread t)) + (sly--responsive-eval + (completions `(,slyfun ,(substring-no-properties pattern) + ',(sly-current-package))) + completions)))) + +(defun sly-simple-completions (prefix) + "Return (COMPLETIONS COMMON) where COMPLETIONS complete the PREFIX. +COMPLETIONS is a list of propertized strings. +COMMON a string, the common prefix." + (cl-loop with first-difference-pos = (length prefix) + with (completions common) = + (sly--completion-request-completions prefix 'slynk-completion:simple-completions) + for completion in completions + do (put-text-property first-difference-pos + (min (1+ first-difference-pos) + (1- (length completion))) + 'face + 'completions-first-difference + completion) + collect completion into formatted + finally return (list formatted common))) + +(defun sly-flex-completions (pattern) + "Return (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. +COMPLETIONS is a list of propertized strings." + (cl-loop with (completions _) = + (sly--completion-request-completions pattern 'slynk-completion:flex-completions) + for (completion score chunks classification suggestion) in completions + do + (cl-loop for (pos substring) in chunks + do (put-text-property pos (+ pos + (length substring)) + 'face + 'completions-first-difference + completion) + collect `(,pos . ,(+ pos (length substring))) into chunks-2 + finally (put-text-property 0 (length completion) + 'sly-completion-chunks chunks-2 + completion)) + (add-text-properties 0 + (length completion) + `(sly--classification ,classification + sly--score ,score + sly--suggestion ,suggestion) + completion) + + collect completion into formatted + finally return (list formatted nil))) + +(defun sly-completion-annotation (completion) + "Compute annotation of COMPLETION as a string. +Return the empty string if none exists." + (let ((classification (get-text-property 0 'sly--classification completion)) + (score (get-text-property 0 'sly--score completion))) + (string-join + (delete nil `(,classification + ,(and score (format "%5.2f%%" (* score 100))))) + " "))) + +;;; backward-compatibility +(defun sly-fuzzy-completions (pattern) + "This function is obsolete since 1.0.0-beta-2; +use ‘sly-flex-completions’ instead, but notice the updated protocol. + +Returns (COMPLETIONS NIL) where COMPLETIONS flex-complete PATTERN. + +COMPLETIONS is a list of elements of the form (STRING NIL NIL +ANNOTATION) describing each completion possibility." + (let ((new (sly-flex-completions pattern))) + (list (mapcar (lambda (string) + (list string nil nil (sly-completion-annotation string))) + (car new)) + (cadr new)))) + +(when (boundp 'completion-category-overrides) + (add-to-list 'completion-category-overrides + '(sly-completion (styles . (sly--external-completion))))) + +(defun sly--completion-function-wrapper (fn) + (let ((cache (make-hash-table :test #'equal))) + (lambda (pattern pred action) + (cl-labels ((all + () + (let ((probe (gethash pattern cache :missing))) + (if (eq probe :missing) + (puthash pattern (funcall fn pattern) cache) + probe)))) + (pcase action + ;; identify this to the custom `sly--completion-in-region-function' + (`sly--identify t) + ;; identify this to other UI's + (`metadata '(metadata + (display-sort-function . identity) + (category . sly-completion))) + ;; all completions + (`t (car (all))) + ;; try completion + (`nil (or (try-completion pattern (car (all))) + pattern)) + (`(boundaries . ,thing) + (completion-boundaries pattern (car (all)) pred thing)) + ;; boundaries or any other value + (_ nil)))))) + +;; This duplicates a function in sly-parse.el +(defun sly--completion-inside-string-or-comment-p () + (let ((ppss (syntax-ppss))) (or (nth 3 ppss) (nth 4 ppss)))) + +(defun sly--completions-complete-symbol-1 (fn) + (let* ((beg (sly-symbol-start-pos)) + (end (sly-symbol-end-pos))) + (append + (list beg end + (sly--completion-function-wrapper fn) + :annotation-function #'sly-completion-annotation + :exit-function (lambda (obj _status) + (let ((suggestion + (get-text-property 0 'sly--suggestion + obj))) + (when suggestion + (delete-region (- (point) (length obj)) (point)) + (insert suggestion)))) + :company-docsig + (lambda (obj) + (when (sit-for 0.1) + (sly--responsive-eval (arglist `(slynk:operator-arglist + ,(substring-no-properties obj) + ,(sly-current-package))) + (or (and arglist + (sly-autodoc--fontify arglist)) + "no autodoc information")))) + :company-no-cache t + :company-doc-buffer + (lambda (obj) + (when (sit-for 0.1) + (sly--responsive-eval (doc `(slynk:describe-symbol + ,(substring-no-properties obj))) + (when doc + (with-current-buffer (get-buffer-create " *sly-completion doc*") + (erase-buffer) + (insert doc) + (current-buffer)))))) + :company-require-match 'never + :company-match + (lambda (obj) + (get-text-property 0 'sly-completion-chunks obj)) + :company-location + (lambda (obj) + (save-window-excursion + (let* ((buffer (sly-edit-definition + (substring-no-properties obj)))) + (when (buffer-live-p buffer) ; on the safe side + (cons buffer (with-current-buffer buffer + (point))))))) + :company-prefix-length + (and (sly--completion-inside-string-or-comment-p) 0)) + (when (eq sly-complete-symbol-function 'sly-flex-completions) + (list + :company-kind + (lambda (obj) + (pcase (get-text-property 0 'sly--classification obj) + ("fn" 'function) + ("generic-fn" 'function) + ("generic-fn,cla" 'method) + ("cla,type" 'class) + ("cla" 'class) + ("special-op" 'operator) + ("type" 'struct) + ("constant" 'constant) + ("var" 'variable) + ("pak" 'module) + ("macro" 'macro)))))))) + +(defun sly-simple-complete-symbol () + "Prefix completion on the symbol at point. +Intended to go into `completion-at-point-functions'" + (sly--completions-complete-symbol-1 'sly-simple-completions)) + +(defun sly-flex-complete-symbol () + "\"Flex\" completion on the symbol at point. +Intended to go into `completion-at-point-functions'" + (sly--completions-complete-symbol-1 'sly-flex-completions)) + +(defun sly-complete-symbol () + "Completion on the symbol at point, using `sly-complete-symbol-function' +Intended to go into `completion-at-point-functions'" + (sly--completions-complete-symbol-1 sly-complete-symbol-function)) + +(defun sly-complete-filename-maybe () + (when (nth 3 (syntax-ppss)) (comint-filename-completion))) + + +;;; Set `completion-at-point-functions' and a few other tricks +;;; +(defun sly--setup-completion () + ;; This one can be customized by a SLY user in `sly-mode-hook' + ;; + (setq-local completion-at-point-functions '(sly-complete-filename-maybe + sly-complete-symbol)) + (add-function :around (local 'completion-in-region-function) + #'sly--completion-in-region-function + '((name . sly--setup-completion)))) + +(define-minor-mode sly-symbol-completion-mode "Fancy SLY UI for Lisp symbols" t + :global t) + +(add-hook 'sly-mode-hook 'sly--setup-completion) + + +;;; TODO: Most of the stuff emulates `completion--in-region' and its +;;; callees in Emacs's minibuffer.el +;;; +(defvar sly--completion-transient-data nil) ; similar to `completion-in-region--data' + +(defvar sly--completion-transient-completions nil) ; not used + +;;; TODO: not tested with other functions in `completion-at-point-functions' +;;; +(defun sly--completion-in-region-function (orig-fun beg end collection pred + &rest rest) + (cond + ((and sly-symbol-completion-mode + (functionp collection) + (funcall collection nil nil 'sly--identify)) + (let* ((pattern (buffer-substring-no-properties beg end)) + (all + (all-completions pattern collection pred)) + (try + (try-completion pattern collection pred))) + (setq this-command 'completion-at-point) ; even if we started with `minibuffer-complete'! + (setq sly--completion-transient-completions all) + (cond ((eq try t) + ;; A unique completion + ;; + (choose-completion-string (cl-first all) + (current-buffer) + (list beg end)) + (sly-temp-message 0 2 "Sole completion")) + ;; Incomplete + ((stringp try) + (let ((pattern-overlay (make-overlay beg end nil nil nil))) + (setq sly--completion-transient-data + `(,pattern-overlay + ,collection + ,pred)) + (overlay-put pattern-overlay 'face 'highlight) + (sly--completion-pop-up-completions-buffer pattern all) + (sly-temp-message 0 2 "Not unique") + (sly--completion-transient-mode 1))) + ((> (length pattern) 0) + (sly-temp-message 0 2 "No completions for %s" pattern))))) + (t + (apply orig-fun beg end collection pred rest)))) + +(defvar sly--completion-in-region-overlay + (let ((ov (make-overlay 0 0))) + (overlay-put ov 'face 'highlight) + (delete-overlay ov) + ov) + "Highlights the currently selected completion candidate") + +(defvar sly--completion-display-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'sly-choose-completion) + (define-key map [mouse-2] 'sly-choose-completion) + (define-key map [backtab] 'sly-prev-completion) + (define-key map (kbd "q") 'sly-completion-hide-completions) + (define-key map (kbd "C-g") 'sly-completion-hide-completions) + (define-key map (kbd "z") 'sly-completion-hide-completions) + (define-key map [remap previous-line] 'sly-prev-completion) + (define-key map [remap next-line] 'sly-next-completion) + (define-key map [left] 'sly-prev-completion) + (define-key map [right] 'sly-next-completion) + (define-key map (kbd "RET") 'sly-choose-completion) + map) + "Keymap used in the *sly-completions* buffer") + +(define-derived-mode sly--completion-display-mode + fundamental-mode "SLY Completions" + "Major mode for presenting SLY completion results.") + +(defun sly--completion-transient-mode-postch () + "Determine whether to pop down the *sly completions* buffer." + (unless (or unread-command-events ; Don't pop down the completions in the middle of + ; mouse-drag-region/mouse-set-point. + (let ((pattern-ov + (and sly--completion-transient-data + (car + sly--completion-transient-data)))) + (and pattern-ov + ;; check if we're in the same buffer + ;; + (eq (overlay-buffer pattern-ov) + (current-buffer)) + ;; check if point is somewhere acceptably related + ;; to the region data that originated the completion + ;; + (<= (overlay-start pattern-ov) + (point) + (overlay-end pattern-ov))))) + (sly--completion-transient-mode -1))) + +(defvar sly--completion-transient-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-n") 'sly-next-completion) + (define-key map (kbd "C-p") 'sly-prev-completion) + (define-key map (kbd "RET") 'sly-choose-completion) + (define-key map "\t" `(menu-item "" sly-choose-completion + :filter (lambda (original) + (when (memq last-command + '(completion-at-point + sly-next-completion + sly-prev-completion)) + original)))) + (define-key map (kbd "C-g") 'sly-quit-completing) + map) + "Keymap used in the buffer originating a *sly-completions* buffer") + +(defvar sly--completion-transient-mode nil + "Explicit `defvar' for `sly--completion-transient-mode'") + +(defun sly--completion-turn-off-transient-mode () + (if (eq major-mode 'sly--completion-display-mode) + (sly-message "Choosing completions directly in %s" (current-buffer)) + (sly-completion-hide-completions))) + +(define-minor-mode sly--completion-transient-mode + "Minor mode when the \"*sly completions*\" buffer is showing" + ;; :lighter " SLY transient completing" + :variable sly--completion-transient-mode + :global t + (remove-hook 'post-command-hook #'sly--completion-transient-mode-postch) + (setq display-buffer-alist + (delq (assq 'sly--completion-transient-mode-display-guard-p display-buffer-alist) + display-buffer-alist)) + (setq minor-mode-overriding-map-alist + (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) + minor-mode-overriding-map-alist)) + (if (null sly--completion-transient-mode) + (sly--completion-turn-off-transient-mode) + (add-hook 'post-command-hook #'sly--completion-transient-mode-postch) + (push `(sly--completion-transient-mode . ,sly--completion-transient-mode-map) + minor-mode-overriding-map-alist) + (push `(sly--completion-transient-mode-display-guard-p + (sly--completion-transient-mode-teardown-before-displaying + . ,display-buffer-alist)) + display-buffer-alist))) + +;; `define-minor-mode' added to `minor-mode-map-alist', but we wanted +;; `minor-mode-overriding-map-alist' instead, so undo changes to +;; `minor-mode-map-alist' +;; +(setq minor-mode-map-alist + (delq (assq 'sly--completion-transient-mode minor-mode-map-alist) + minor-mode-map-alist)) + +;; displaying other buffers with pop-to-buffer while in +;; `sly--completion-transient-mode' is problematic, because it +;; dedicates a window. Try some crazy `display-buffer-alist' shit to +;; prevent that. +;; +(defun sly--completion-transient-mode-display-guard-p (buffer-name _action) + (not (string-match-p "^*sly-completions*" buffer-name))) + +(defun sly--completion-transient-mode-teardown-before-displaying (_buffer _alist) + (sly--completion-transient-mode -1) + ;; returns nil, hoping some other function in alist will display the + ;; buffer as intended. + nil) + +(defun sly--completion-kill-transient-data () + (when (overlayp (car sly--completion-transient-data)) + (delete-overlay (car sly--completion-transient-data))) + (setq sly--completion-transient-data nil)) + +(defun sly-completion-hide-completions () + (interactive) + (sly--completion-kill-transient-data) + (let* ((buffer (get-buffer (sly-buffer-name :completions))) + (win (and buffer + (get-buffer-window buffer 0)))) + (when win (with-selected-window win (quit-window t))))) + +(defvar sly--completion-reference-buffer nil + "Like `completion-reference-buffer', which see") + +(defmacro sly--completion-with-displayed-buffer-window (buffer + action + quit-function + &rest body) + ;;; WITH-DISPLAYED-BUFFER-WINDOW doesn't work noninteractively + (let ((original-sym (cl-gensym "original-buffer-"))) + `(if noninteractive + (let ((,original-sym (current-buffer))) + (display-buffer (get-buffer-create ,buffer) ,action) + (let ((standard-output ,buffer)) + (with-current-buffer ,original-sym + ,@body))) + (with-displayed-buffer-window ,buffer ,action ,quit-function + ,@body)))) + +(defun sly--completion-pop-up-completions-buffer (_pattern completions) + (let ((display-buffer-mark-dedicated 'soft) + (pop-up-windows nil) + completions-buffer first-completion-point) + (sly--completion-with-displayed-buffer-window + (sly-buffer-name :completions) + `((display-buffer--maybe-same-window + display-buffer-reuse-window + display-buffer--maybe-pop-up-frame-or-window + ;; Use `display-buffer-below-selected' for inline completions, + ;; but not in the minibuffer (e.g. in `eval-expression') + ;; for which `display-buffer-at-bottom' is used. + ,(if (eq (selected-window) (minibuffer-window)) + 'display-buffer-at-bottom + 'display-buffer-below-selected)) + ,(if temp-buffer-resize-mode + '(window-height . resize-temp-buffer-window) + '(window-height . shrink-window-if-larger-than-buffer)) + ,(when temp-buffer-resize-mode + '(preserve-size . (nil . t)))) + nil + (sly--completion-transient-mode) + (let ((reference (current-buffer))) + (with-current-buffer standard-output + (sly--completion-display-mode) + (set (make-local-variable 'cursor-type) nil) + (setq sly--completion-reference-buffer reference) + (sly--completion-fill-completions-buffer completions) + (setq completions-buffer standard-output + first-completion-point (point)) + (add-hook 'kill-buffer-hook 'sly--completion-kill-transient-data t t)))) + (with-current-buffer completions-buffer + (goto-char first-completion-point)))) + +(defvar sly--completion-explanation + (concat "Use \\[sly-next-completion] and \\[sly-prev-completion] to navigate completions." + " \\[sly-choose-completion] or [mouse-1] selects a completion." + "\n\nAnnotation flags: (b)oundp (f)boundp (g)eneric-function (c)lass (m)acro (s)pecial-operator\n\n")) + +(defun sly--completion-fill-completions-buffer (completions) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (substitute-command-keys + sly--completion-explanation)) + (cl-loop with first = (point) + for completion in completions + for annotation = (sly-completion-annotation completion) + for start = (point) + do + (cl-loop for (beg . end) in + (get-text-property 0 'sly-completion-chunks completion) + do (put-text-property beg + end + 'face + 'completions-common-part completion)) + (insert (propertize completion + 'mouse-face 'highlight + 'sly--completion t)) + (insert (make-string (max + 1 + (- (1- (window-width)) + (length completion) + (length annotation))) + ? ) + annotation) + (put-text-property start (point) 'sly--completion completion) + (insert "\n") + finally (goto-char first) (sly-next-completion 0)))) + +(defun sly-next-completion (n &optional errorp) + (interactive "p") + (with-current-buffer (sly-buffer-name :completions) + (when (overlay-buffer sly--completion-in-region-overlay) + (goto-char (overlay-start sly--completion-in-region-overlay))) + (forward-line n) + (let* ((end (and (get-text-property (point) 'sly--completion) + (save-excursion + (skip-syntax-forward "^\s") + (point)) + ;; (next-single-char-property-change (point) 'sly--completion) + )) + (beg (and end + (previous-single-char-property-change end 'sly--completion)))) + (if (and beg end) + (progn + (move-overlay sly--completion-in-region-overlay + beg end) + (let ((win (get-buffer-window (current-buffer) 0))) + (when win + (with-selected-window win + (goto-char beg) + (sly-recenter beg))))) + (if errorp + (sly-error "No completion at point")))))) + +(defun sly-prev-completion (n) + (interactive "p") + (sly-next-completion (- n))) + +(defun sly-choose-completion (&optional event) + (interactive (list last-nonmenu-event)) + ;; In case this is run via the mouse, give temporary modes such as + ;; isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (with-current-buffer (sly-buffer-name :completions) + (when event + (goto-char (posn-point (event-start event))) + (sly-next-completion 0 t)) + (let ((completion-text + (buffer-substring-no-properties (overlay-start sly--completion-in-region-overlay) + (overlay-end sly--completion-in-region-overlay)))) + (unless (buffer-live-p sly--completion-reference-buffer) + (sly-error "Destination buffer is dead")) + (choose-completion-string completion-text + sly--completion-reference-buffer + (let ((pattern-ov + (car sly--completion-transient-data))) + (list (overlay-start pattern-ov) + (overlay-end pattern-ov)))) + (sly--completion-transient-mode -1)))) + +(defun sly-quit-completing () + (interactive) + (when sly--completion-transient-mode + (sly--completion-transient-mode -1)) + (keyboard-quit)) + + + +;;;; Minibuffer reading + +(defvar sly-minibuffer-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\t" 'completion-at-point) + map) + "Minibuffer keymap used for reading CL expressions.") + + +(defvar sly-minibuffer-history '() + "History list of expressions read from the minibuffer.") + +(defvar sly-minibuffer-symbol-history '() + "History list of symbols read from the minibuffer.") + +(defmacro sly--with-sly-minibuffer (&rest body) + `(let* ((minibuffer-setup-hook + (cons (lambda () + (set-syntax-table lisp-mode-syntax-table) + (sly--setup-completion)) + minibuffer-setup-hook)) + (sly-buffer-package (sly-current-package)) + (sly-buffer-connection (sly-connection))) + ,@body)) + +(defvar sly-minibuffer-setup-hook nil + "Setup SLY-specific minibuffer reads. +Used mostly (only?) by `sly-autodoc-mode'.") + +(defun sly-read-from-minibuffer (prompt &optional initial-value history allow-empty keymap) + "Read a string from the minibuffer, prompting with PROMPT. +If INITIAL-VALUE is non-nil, it is inserted into the minibuffer +before reading input. The result is a string (\"\" if no input +was given and ALLOW-EMPTY is non-nil)." + (sly--with-sly-minibuffer + (cl-loop + with minibuffer-setup-hook = (cons + (lambda () + (run-hooks 'sly-minibuffer-setup-hook)) + minibuffer-setup-hook) + for i from 0 + for read = (read-from-minibuffer + (concat "[sly] " (when (cl-plusp i) + "[can't be blank] ") + prompt) + (and (zerop i) + initial-value) + (or keymap sly-minibuffer-map) + nil (or history 'sly-minibuffer-history)) + when (or (> (length read) 0) + allow-empty) + return read))) + +(defun sly-read-symbol-name (prompt &optional query) + "Either read a symbol name or choose the one at point. +The user is prompted if a prefix argument is in effect, if there is no +symbol at point, or if QUERY is non-nil." + (let* ((sym-at-point (sly-symbol-at-point)) + (completion-category-overrides + (cons '(sly-completion (styles . (sly--external-completion))) + completion-category-overrides)) + (wrapper (sly--completion-function-wrapper sly-complete-symbol-function)) + (do-it (lambda () (completing-read prompt wrapper nil nil sym-at-point)))) + (cond ((or current-prefix-arg query (not sym-at-point)) + (cond (sly-symbol-completion-mode + (let ((icomplete-mode nil) + (completing-read-function #'completing-read-default)) + (sly--with-sly-minibuffer (funcall do-it)))) + (t (funcall do-it)))) + (t sym-at-point)))) + +(defun sly--read-method (prompt-for-generic + prompt-for-method-within-generic) + "Read triplet (GENERIC-NAME QUALIFIERS SPECIALIZERS) for a method." + (let* ((generic-name (sly-read-symbol-name prompt-for-generic t)) + (format-spec (lambda (spec) + (let ((qualifiers (car spec))) + (if (null qualifiers) + (format "%s" (cadr spec)) + (format "%s %s" (string-join qualifiers " ") + (cadr spec)))))) + (methods-by-formatted-name + (cl-loop for spec in (sly-eval `(slynk:generic-method-specs ,generic-name)) + collect (cons (funcall format-spec spec) spec))) + (context-at-point (sly-parse-context generic-name)) + (probe (and (eq :defmethod (car context-at-point)) + (equal generic-name (cadr context-at-point)) + (string-replace + "'" "" (mapconcat #'prin1-to-string (cddr context-at-point) + " ")))) + default + (reordered + (cl-loop for e in methods-by-formatted-name + if (cl-equalp (car e) probe) do (setq default e) + else collect e into others + finally (cl-return (if default (cons default others) + others))))) + (unless reordered + (sly-user-error "Generic `%s' doesn't have any methods!" generic-name)) + (cons generic-name + (cdr (assoc (completing-read + (concat (format prompt-for-method-within-generic generic-name) + (if default (format " (default %s)" (car default))) + ": ") + (mapcar #'car reordered) + nil t nil nil (car default)) + reordered))))) + +(provide 'sly-completion) +;;; sly-completion.el ends here blob - /dev/null blob + d6b911fcc3b05f217705ef94bb03d14928d8e56d (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-messages.el @@ -0,0 +1,137 @@ +;;; sly-messages.el --- Messages, errors, echo-area and visual feedback utils for SLY -*- lexical-binding: t; -*- + +;; Copyright (C) 2014 João Távora + +;; Author: João Távora +;; Keywords: + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) + +(defvar sly--last-message nil) + +(defun sly-message (format-string &rest args) + "Like `message', but use a prefix." + (let ((body (apply #'format format-string args))) + (setq sly--last-message (format "[sly] %s" body)) + (message "%s" sly--last-message))) + +(add-hook 'echo-area-clear-hook + 'sly--message-clear-last-message) + +(defun sly--message-clear-last-message () + (setq sly--last-message nil)) + +(defun sly-temp-message (wait sit-for format &rest args) + "Wait WAIT seconds then display a message for SIT-FOR seconds. +A nil value for WAIT means \"now\". +SIT-FOR is has the semantincs of `minibuffer-message-timeout', which see." + (run-with-timer + wait nil + #'(lambda () + (let ((existing sly--last-message) + (text (apply #'format format args))) + (if (minibuffer-window-active-p (minibuffer-window)) + (let ((minibuffer-message-timeout sit-for)) + (minibuffer-message "[sly] %s" text)) + (message "[sly] %s" text) ; don't sly-message here + (run-with-timer + sit-for + nil + #'(lambda () + ;; restore the message + (when existing + (message "%s" existing))))))))) + +(defun sly-warning (format-string &rest args) + (display-warning '(sly warning) (apply #'format format-string args))) + +(defun sly-error (format-string &rest args) + (apply #'error (format "[sly] %s" format-string) args)) + +(defun sly-user-error (format-string &rest args) + (apply #'user-error (format "[sly] %s" format-string) args)) + +(defun sly-display-oneliner (format-string &rest format-args) + (let* ((msg (apply #'format format-string format-args))) + (unless (minibuffer-window-active-p (minibuffer-window)) + (sly-message (sly-oneliner msg))))) + +(defun sly-oneliner (string) + "Return STRING truncated to fit in a single echo-area line." + (substring string 0 (min (length string) + (or (cl-position ?\n string) most-positive-fixnum) + (1- (window-width (minibuffer-window)))))) + +(defun sly-y-or-n-p (format-string &rest args) + (let ((prompt (apply #'format (concat "[sly] " + format-string) + args))) + (y-or-n-p prompt))) + + +;;; Flashing the region +;;; +(defvar sly-flash-inhibit nil + "If non-nil `sly-flash-region' does nothing") + +(defvar sly--flash-overlay (make-overlay 0 0)) +(overlay-put sly--flash-overlay 'priority 1000) + +(cl-defun sly-flash-region (start end &key + timeout + face + times + (pattern '(0.2))) + "Temporarily highlight region from START to END." + (if pattern + (cl-assert (and (null times) (null timeout)) + nil + "If PATTERN is supplied, don't supply TIMES or TIMEOUT") + (setq pattern (make-list (* 2 times) timeout))) + (unless sly-flash-inhibit + (let ((buffer (current-buffer))) + (move-overlay sly--flash-overlay start end buffer) + (cl-labels + ((on () (overlay-put sly--flash-overlay 'face (or face 'highlight))) + (off () (overlay-put sly--flash-overlay 'face nil)) + (relevant-p () + (equal (list start end buffer) + (list (overlay-start sly--flash-overlay) + (overlay-end sly--flash-overlay) + (overlay-buffer sly--flash-overlay)))) + (onoff () + (when (and pattern (relevant-p)) + (on) + (run-with-timer (pop pattern) + nil + (lambda () + (when (relevant-p) + (off) + (when pattern + (run-with-timer + (pop pattern) + nil + (lambda () (onoff)))))))))) + (onoff))))) + +(provide 'sly-messages) +;;; sly-messages.el ends here blob - /dev/null blob + c303b57029bbe9f3da1e06fb7c7dd1ddcdbac754 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-parse.el @@ -0,0 +1,355 @@ +;; -*- lexical-binding: t; -*- +(require 'sly) +(require 'cl-lib) + +(defun sly-parse-form-until (limit form-suffix) + "Parses form from point to `limit'." + ;; For performance reasons, this function does not use recursion. + (let ((todo (list (point))) ; stack of positions + (sexps) ; stack of expressions + (cursexp) + (curpos) + (depth 1)) ; This function must be called from the + ; start of the sexp to be parsed. + (while (and (setq curpos (pop todo)) + (progn + (goto-char curpos) + ;; (Here we also move over suppressed + ;; reader-conditionalized code! Important so CL-side + ;; of autodoc won't see that garbage.) + (ignore-errors (sly-forward-cruft)) + (< (point) limit))) + (setq cursexp (pop sexps)) + (cond + ;; End of an sexp? + ((and (or (looking-at "\\s)") (eolp)) sexps) + (cl-decf depth) + (push (nreverse cursexp) (car sexps))) + ;; Start of a new sexp? + ((looking-at "\\(\\s'\\|@\\)*\\s(") + (let ((subpt (match-end 0))) + (ignore-errors + (forward-sexp) + ;; (In case of error, we're at an incomplete sexp, and + ;; nothing's left todo after it.) + (push (point) todo)) + (push cursexp sexps) + (push subpt todo) ; to descend into new sexp + (push nil sexps) + (cl-incf depth))) + ;; In mid of an sexp.. + (t + (let ((pt1 (point)) + (pt2 (condition-case e + (progn (forward-sexp) (point)) + (scan-error + (cl-fourth e))))) ; end of sexp + (push (buffer-substring-no-properties pt1 pt2) cursexp) + (push pt2 todo) + (push cursexp sexps))))) + (when sexps + (setf (car sexps) (cl-nreconc form-suffix (car sexps))) + (while (> depth 1) + (push (nreverse (pop sexps)) (car sexps)) + (cl-decf depth)) + (nreverse (car sexps))))) + +(defun sly-compare-char-syntax (get-char-fn syntax &optional unescaped) + "Returns t if the character that `get-char-fn' yields has +characer syntax of `syntax'. If `unescaped' is true, it's ensured +that the character is not escaped." + (let ((char (funcall get-char-fn (point))) + (char-before (funcall get-char-fn (1- (point))))) + (if (and char (eq (char-syntax char) (aref syntax 0))) + (if unescaped + (or (null char-before) + (not (eq (char-syntax char-before) ?\\))) + t) + nil))) + +(defconst sly-cursor-marker 'slynk::%cursor-marker%) + +;; FIXME: stop this madness and just use `syntax-ppss' +;; +(defun sly-parse-form-upto-point (&optional max-levels) + (save-restriction + (let ((ppss (syntax-ppss))) + ;; Don't parse more than 500 lines before point, so we don't spend + ;; too much time. NB. Make sure to go to beginning of line, and + ;; not possibly anywhere inside comments or strings. + (narrow-to-region (line-beginning-position -500) (point-max)) + (save-excursion + (let ((suffix (list sly-cursor-marker))) + (cond ((sly-compare-char-syntax #'char-after "(" t) + ;; We're at the start of some expression, so make sure + ;; that SLYNK::%CURSOR-MARKER% will come after that + ;; expression. If the expression is not balanced, make + ;; still sure that the marker does *not* come directly + ;; after the preceding expression. + (or (ignore-errors (forward-sexp) t) + (push "" suffix))) + ((or (bolp) (sly-compare-char-syntax #'char-before " " t)) + ;; We're after some expression, so we have to make sure + ;; that %CURSOR-MARKER% does *not* come directly after + ;; that expression. + (push "" suffix)) + ((sly-compare-char-syntax #'char-before "(" t) + ;; We're directly after an opening parenthesis, so we + ;; have to make sure that something comes before + ;; %CURSOR-MARKER%. + (push "" suffix)) + (t + ;; We're at a symbol, so make sure we get the whole symbol. + (sly-end-of-symbol))) + (let ((pt (point))) + (unless (zerop (car ppss)) + (ignore-errors (up-list (if max-levels (- max-levels) -5)))) + (ignore-errors (down-list)) + (sly-parse-form-until pt suffix))))))) + +;;;; Test cases +(defun sly-extract-context () + "Parse the context for the symbol at point. +Nil is returned if there's no symbol at point. Otherwise we detect +the following cases (the . shows the point position): + + (defun n.ame (...) ...) -> (:defun name) + (defun (setf n.ame) (...) ...) -> (:defun (setf name)) + (defmethod n.ame (...) ...) -> (:defmethod name (...)) + (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) + (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) + (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) + (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) + + (defmacro n.ame (...) ...) -> (:defmacro name) + (defsetf n.ame (...) ...) -> (:defsetf name) + (define-setf-expander n.ame (...) ...) -> (:define-setf-expander name) + (define-modify-macro n.ame (...) ...) -> (:define-modify-macro name) + (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name) + (defvar n.ame (...) ...) -> (:defvar name) + (defparameter n.ame ...) -> (:defparameter name) + (defconstant n.ame ...) -> (:defconstant name) + (defclass n.ame ...) -> (:defclass name) + (defstruct n.ame ...) -> (:defstruct name) + (defpackage n.ame ...) -> (:defpackage name) +For other contexts we return the symbol at point." + (let ((name (sly-symbol-at-point))) + (if name + (let ((symbol (read name))) + (or (progn ;;ignore-errors + (sly-parse-context symbol)) + symbol))))) + +(defun sly-parse-context (name) + (save-excursion + (cond ((sly-in-expression-p '(defun *)) `(:defun ,name)) + ((sly-in-expression-p '(defmacro *)) `(:defmacro ,name)) + ((sly-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) + ((sly-in-expression-p '(setf *)) + ;;a setf-definition, but which? + (backward-up-list 1) + (sly-parse-context `(setf ,name))) + ((sly-in-expression-p '(defmethod *)) + (unless (looking-at "\\s ") + (forward-sexp 1)) ; skip over the methodname + (let (qualifiers arglist) + (cl-loop for e = (read (current-buffer)) + until (listp e) do (push e qualifiers) + finally (setq arglist e)) + `(:defmethod ,name ,@qualifiers + ,(sly-arglist-specializers arglist)))) + ((and (symbolp name) + (sly-in-expression-p `(,name))) + ;; looks like a regular call + (let ((toplevel (ignore-errors (sly-parse-toplevel-form)))) + (cond ((sly-in-expression-p `(setf (*))) ;a setf-call + (if toplevel + `(:call ,toplevel (setf ,name)) + `(setf ,name))) + ((not toplevel) + name) + ((sly-in-expression-p `(labels ((*)))) + `(:labels ,toplevel ,name)) + ((sly-in-expression-p `(flet ((*)))) + `(:flet ,toplevel ,name)) + (t + `(:call ,toplevel ,name))))) + ((sly-in-expression-p '(define-compiler-macro *)) + `(:define-compiler-macro ,name)) + ((sly-in-expression-p '(define-modify-macro *)) + `(:define-modify-macro ,name)) + ((sly-in-expression-p '(define-setf-expander *)) + `(:define-setf-expander ,name)) + ((sly-in-expression-p '(defsetf *)) + `(:defsetf ,name)) + ((sly-in-expression-p '(defvar *)) `(:defvar ,name)) + ((sly-in-expression-p '(defparameter *)) `(:defparameter ,name)) + ((sly-in-expression-p '(defconstant *)) `(:defconstant ,name)) + ((sly-in-expression-p '(defclass *)) `(:defclass ,name)) + ((sly-in-expression-p '(defpackage *)) `(:defpackage ,name)) + ((sly-in-expression-p '(defstruct *)) + `(:defstruct ,(if (consp name) + (car name) + name))) + (t + name)))) + + +(defun sly-in-expression-p (pattern) + "A helper function to determine the current context. +The pattern can have the form: + pattern ::= () ;matches always + | (*) ;matches inside a list + | ( ) ;matches if the first element in + ; the current list is and + ; if matches. + | (()) ;matches if we are in a nested list." + (save-excursion + (let ((path (reverse (sly-pattern-path pattern)))) + (cl-loop for p in path + always (ignore-errors + (cl-etypecase p + (symbol (sly-beginning-of-list) + (eq (read (current-buffer)) p)) + (number (backward-up-list p) + t))))))) + +(defun sly-pattern-path (pattern) + ;; Compute the path to the * in the pattern to make matching + ;; easier. The path is a list of symbols and numbers. A number + ;; means "(down-list )" and a symbol "(look-at )") + (if (null pattern) + '() + (cl-etypecase (car pattern) + ((member *) '()) + (symbol (cons (car pattern) (sly-pattern-path (cdr pattern)))) + (cons (cons 1 (sly-pattern-path (car pattern))))))) + +(defun sly-beginning-of-list (&optional up) + "Move backward to the beginning of the current expression. +Point is placed before the first expression in the list." + (backward-up-list (or up 1)) + (down-list 1) + (skip-syntax-forward " ")) + +(defun sly-end-of-list (&optional up) + (backward-up-list (or up 1)) + (forward-list 1) + (down-list -1)) + +(defun sly-parse-toplevel-form () + (ignore-errors ; (foo) + (save-excursion + (goto-char (car (sly-region-for-defun-at-point))) + (down-list 1) + (forward-sexp 1) + (sly-parse-context (read (current-buffer)))))) + +(defun sly-arglist-specializers (arglist) + (cond ((or (null arglist) + (member (cl-first arglist) '(&optional &key &rest &aux))) + (list)) + ((consp (cl-first arglist)) + (cons (cl-second (cl-first arglist)) + (sly-arglist-specializers (cl-rest arglist)))) + (t + (cons 't + (sly-arglist-specializers (cl-rest arglist)))))) + +(defun sly-definition-at-point (&optional only-functional) + "Return object corresponding to the definition at point." + (let ((toplevel (sly-parse-toplevel-form))) + (if (or (symbolp toplevel) + (and only-functional + (not (member (car toplevel) + '(:defun :defgeneric :defmethod + :defmacro :define-compiler-macro))))) + (error "Not in a definition") + (sly-dcase toplevel + (((:defun :defgeneric) symbol) + (format "#'%s" symbol)) + (((:defmacro :define-modify-macro) symbol) + (format "(macro-function '%s)" symbol)) + ((:define-compiler-macro symbol) + (format "(compiler-macro-function '%s)" symbol)) + ((:defmethod symbol &rest args) + (declare (ignore args)) + (format "#'%s" symbol)) + (((:defparameter :defvar :defconstant) symbol) + (format "'%s" symbol)) + (((:defclass :defstruct) symbol) + (format "(find-class '%s)" symbol)) + ((:defpackage symbol) + (format "(or (find-package '%s) (error \"Package %s not found\"))" + symbol symbol)) + (t + (error "Not in a definition")))))) + +(defsubst sly-current-parser-state () + ;; `syntax-ppss' does not save match data as it invokes + ;; `beginning-of-defun' implicitly which does not save match + ;; data. This issue has been reported to the Emacs maintainer on + ;; Feb27. + (syntax-ppss)) + +(defun sly-inside-string-p () + (nth 3 (sly-current-parser-state))) + +(defun sly-inside-comment-p () + (nth 4 (sly-current-parser-state))) + +(defun sly-inside-string-or-comment-p () + (let ((state (sly-current-parser-state))) + (or (nth 3 state) (nth 4 state)))) + +;;; The following two functions can be handy when inspecting +;;; source-location while debugging `M-.'. +;;; +(defun sly-current-tlf-number () + "Return the current toplevel number." + (interactive) + (let ((original-pos (car (sly-region-for-defun-at-point))) + (n 0)) + (save-excursion + ;; We use this and no repeated `beginning-of-defun's to get + ;; reader conditionals right. + (goto-char (point-min)) + (while (progn (sly-forward-sexp) + (< (point) original-pos)) + (cl-incf n))) + n)) + +;;; This is similiar to `sly-enclosing-form-paths' in the +;;; `sly-parse' contrib except that this does not do any duck-tape +;;; parsing, and gets reader conditionals right. +(defun sly-current-form-path () + "Returns the path from the beginning of the current toplevel +form to the atom at point, or nil if we're in front of a tlf." + (interactive) + (let ((source-path nil)) + (save-excursion + ;; Moving forward to get reader conditionals right. + (cl-loop for inner-pos = (point) + for outer-pos = (cl-nth-value 1 (sly-current-parser-state)) + while outer-pos do + (goto-char outer-pos) + (unless (eq (char-before) ?#) ; when at #(...) continue. + (forward-char) + (let ((n 0)) + (while (progn (sly-forward-sexp) + (< (point) inner-pos)) + (cl-incf n)) + (push n source-path) + (goto-char outer-pos))))) + source-path)) + + +;;; Compile hotspots +;;; +(sly-byte-compile-hotspots + '(sly-parse-form-upto-point + sly-parse-form-until + sly-compare-char-syntax)) + + +(provide 'sly-parse) blob - /dev/null blob + a6304864b44573fbd5f76da771d8a44eeefb1048 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/lib/sly-tests.el @@ -0,0 +1,1545 @@ +;;; sly-tests.el --- Automated tests for sly.el -*- lexical-binding: t; -*- +;; +;;;; License +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2013 +;; +;; For a detailed list of contributors, see the manual. +;; +;; This program 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 of +;; the License, or (at your option) any later version. +;; +;; This program 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 this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;; MA 02111-1307, USA. + + +;;;; Tests +(require 'sly) +(require 'ert nil t) +(require 'ert "lib/ert" t) ;; look for bundled version for Emacs 23 +(require 'cl-lib) +(require 'bytecomp) ; byte-compile-current-file + +(defun sly-shuffle-list (list) + (let* ((len (length list)) + (taken (make-vector len nil)) + (result (make-vector len nil))) + (dolist (e list) + (while (let ((i (random len))) + (cond ((aref taken i)) + (t (aset taken i t) + (aset result i e) + nil))))) + (append result '()))) + +(defun sly-batch-test (&optional test-name randomize) + "Run the test suite in batch-mode. +Exits Emacs when finished. The exit code is the number of failed tests." + (interactive) + (let ((ert-debug-on-error nil) + (timeout 30)) + (sly) + ;; Block until we are up and running. + (let (timed-out) + (run-with-timer timeout nil + (lambda () (setq timed-out t))) + (while (not (sly-connected-p)) + (sit-for 1) + (when timed-out + (when noninteractive + (kill-emacs 252))))) + (sly-sync-to-top-level 5) + (let* ((selector (if randomize + `(member ,@(sly-shuffle-list + (ert-select-tests (or test-name t) t))) + (or test-name t))) + (ert-fun (if noninteractive + 'ert-run-tests-batch + 'ert))) + (let ((stats (funcall ert-fun selector))) + (if noninteractive + (kill-emacs (ert-stats-completed-unexpected stats))))))) + +(defun sly-skip-test (message) + ;; ERT for Emacs 23 and earlier doesn't have `ert-skip' + (if (fboundp 'ert-skip) + (ert-skip message) + (message (concat "SKIPPING: " message)) + (ert-pass))) + +(defun sly-tests--undefine-all () + (dolist (test (ert-select-tests t t)) + (let ((sym (ert-test-name test))) + (cl-assert (eq (get sym 'ert--test) test)) + (cl-remprop sym 'ert--test)))) + +(sly-tests--undefine-all) + +(eval-and-compile + (defun sly-tests-auto-tags () + (append '(sly) + (let ((file-name (or load-file-name + byte-compile-current-file))) + (if (and (stringp file-name) + (string-match "test/sly-\\(.*\\)\.elc?$" file-name)) + (list 'contrib (intern (match-string 1 file-name))) + '(core))))) + + (defmacro define-sly-ert-test (name &rest args) + "Like `ert-deftest', but set tags automatically. +Also don't error if `ert.el' is missing." + (declare (debug (&define name sexp sexp &rest def-form))) + (let* ((docstring (and (stringp (cl-second args)) + (cl-second args))) + (args (if docstring + (cddr args) + (cdr args))) + (tags (sly-tests-auto-tags))) + `(ert-deftest ,name () ,(or docstring "No docstring for this test.") + :tags ',tags + ,@args))) + + (defun sly-test-ert-test-for (name input i doc _body fails-for style fname) + `(define-sly-ert-test + ,(intern (format "%s-%d" name i)) () + ,(format "For input %s, %s" (truncate-string-to-width + (format "%s" input) + 15 nil nil 'ellipsis) + (replace-regexp-in-string "^.??\\(\\w+\\)" + (lambda (s) (downcase s)) + doc + t)) + ,@(if fails-for + `(:expected-result + '(satisfies + (lambda (result) + (ert-test-result-type-p + result + (if (cl-find-if + (lambda (impl) + (unless (listp impl) + (setq impl (list impl #'(lambda (&rest _ign) t)))) + (and (equal (car impl) (sly-lisp-implementation-name)) + (funcall + (cadr impl) + ;; Appease `version-to-list' for + ;; SBCL. `version-regexp-alist' + ;; doesn't work here. + (replace-regexp-in-string + "[-._+ ]?[[:alnum:]]\\{7,9\\}$" + "-snapshot" + (sly-lisp-implementation-version)) + (caddr impl)))) + ',fails-for) + :failed + :passed)))))) + + ,@(when style + `((let ((style (sly-communication-style))) + (when (not (member style ',style)) + (sly-skip-test (format "test not applicable for style %s" + style)))))) + (apply #',fname ',input)))) + +(defmacro def-sly-test (name args doc inputs &rest body) + "Define a test case. +NAME ::= SYMBOL | (SYMBOL OPTION*) is a symbol naming the test. +OPTION ::= (:fails-for IMPLEMENTATION*) | (:style COMMUNICATION-STYLE*) +ARGS is a lambda-list. +DOC is a docstring. +INPUTS is a list of argument lists, each tested separately. +BODY is the test case. The body can use `sly-check' to test +conditions (assertions)." + (declare (debug (&define name sexp sexp sexp &rest def-form)) + (indent 4)) + (if (not (featurep 'ert)) + (warn "No ert.el found: not defining test %s" + name) + `(progn + ,@(cl-destructuring-bind (name &rest options) + (if (listp name) name (list name)) + (let ((fname (intern (format "sly-test-%s" name)))) + (cons `(defun ,fname ,args + (sly-sync-to-top-level 0.3) + ,@body + (sly-sync-to-top-level 0.3)) + (cl-loop for input in (eval inputs) + for i from 1 + with fails-for = (cdr (assoc :fails-for options)) + with style = (cdr (assoc :style options)) + collect (sly-test-ert-test-for name + input + i + doc + body + fails-for + style + fname)))))))) + +(defmacro sly-check (check &rest body) + (declare (indent defun)) + `(unless (progn ,@body) + (ert-fail ,(cl-etypecase check + (cons `(concat "Ooops, " ,(cons 'format check))) + (string `(concat "Check failed: " ,check)) + (symbol `(concat "Check failed: " ,(symbol-name check))))))) + + +;;;;; Test case definitions +(defun sly-check-top-level () ;(&optional _test-name) + (accept-process-output nil 0.001) + (sly-check "At the top level (no debugging or pending RPCs)" + (sly-at-top-level-p))) + +(defun sly-at-top-level-p () + (and (not (sly-db-get-default-buffer)) + (null (sly-rex-continuations)))) + +(defun sly-wait-condition (name predicate timeout &optional cleanup) + (let ((end (time-add (current-time) (seconds-to-time timeout)))) + (while (not (funcall predicate)) + (sly-message "waiting for condition: %s [%s]" name + (format-time-string "%H:%M:%S.%6N")) + (cond ((time-less-p end (current-time)) + (unwind-protect + (error "Timeout waiting for condition: %S" name) + (funcall cleanup))) + (t + ;; XXX if a process-filter enters a recursive-edit, we + ;; hang forever + (accept-process-output nil 0.1)))))) + +(defun sly-sync-to-top-level (timeout) + (sly-wait-condition "top-level" #'sly-at-top-level-p timeout + (lambda () + (let ((sly-db-buffer + (sly-db-get-default-buffer))) + (when (bufferp sly-db-buffer) + (with-current-buffer sly-db-buffer + (sly-db-quit))))))) + +;; XXX: unused function +(defun sly-check-sly-db-level (expected) + (let ((sly-db-level (let ((sly-db (sly-db-get-default-buffer))) + (if sly-db + (with-current-buffer sly-db + sly-db-level))))) + (sly-check ("SLY-DB level (%S) is %S" expected sly-db-level) + (equal expected sly-db-level)))) + +(defun sly-test-expect (_name expected actual &optional test) + (when (stringp expected) (setq expected (substring-no-properties expected))) + (when (stringp actual) (setq actual (substring-no-properties actual))) + (if test + (should (funcall test expected actual)) + (should (equal expected actual)))) + +(defun sly-db-level () + (let ((sly-db (sly-db-get-default-buffer))) + (if sly-db + (with-current-buffer sly-db + sly-db-level)))) + +(defun sly-sly-db-level= (level) + (equal level (sly-db-level))) + +(eval-when-compile + (defvar sly-test-symbols + '(("foobar") ("foo@bar") ("@foobar") ("foobar@") ("\\@foobar") + ("|asdf||foo||bar|") + ("\\#") + ("\\(setf\\ car\\)")))) + +(defun sly-check-symbol-at-point (prefix symbol suffix) + ;; We test that `sly-symbol-at-point' works at every + ;; character of the symbol name. + (with-temp-buffer + (lisp-mode) + (insert prefix) + (let ((start (point))) + (insert symbol suffix) + (dotimes (i (length symbol)) + (goto-char (+ start i)) + (sly-test-expect (format "Check `%s' (at %d)..." + (buffer-string) (point)) + symbol + (sly-symbol-at-point) + #'equal))))) + + + +(def-sly-test symbol-at-point.2 (sym) + "fancy symbol-name _not_ at BOB/EOB" + sly-test-symbols + (sly-check-symbol-at-point "(foo " sym " bar)")) + +(def-sly-test symbol-at-point.3 (sym) + "fancy symbol-name with leading ," + (cl-remove-if (lambda (s) (eq (aref (car s) 0) ?@)) sly-test-symbols) + (sly-check-symbol-at-point "," sym "")) + +(def-sly-test symbol-at-point.4 (sym) + "fancy symbol-name with leading ,@" + sly-test-symbols + (sly-check-symbol-at-point ",@" sym "")) + +(def-sly-test symbol-at-point.5 (sym) + "fancy symbol-name with leading `" + sly-test-symbols + (sly-check-symbol-at-point "`" sym "")) + +(def-sly-test symbol-at-point.6 (sym) + "fancy symbol-name wrapped in ()" + sly-test-symbols + (sly-check-symbol-at-point "(" sym ")")) + +(def-sly-test symbol-at-point.7 (sym) + "fancy symbol-name wrapped in #< {DEADBEEF}>" + sly-test-symbols + (sly-check-symbol-at-point "#<" sym " {DEADBEEF}>")) + +;;(def-sly-test symbol-at-point.8 (sym) +;; "fancy symbol-name wrapped in #<>" +;; sly-test-symbols +;; (sly-check-symbol-at-point "#<" sym ">")) + +(def-sly-test symbol-at-point.9 (sym) + "fancy symbol-name wrapped in #| ... |#" + sly-test-symbols + (sly-check-symbol-at-point "#|\n" sym "\n|#")) + +(def-sly-test symbol-at-point.10 (sym) + "fancy symbol-name after #| )))(( |# (1)" + sly-test-symbols + (sly-check-symbol-at-point "#| )))(( #|\n" sym "")) + +(def-sly-test symbol-at-point.11 (sym) + "fancy symbol-name after #| )))(( |# (2)" + sly-test-symbols + (sly-check-symbol-at-point "#| )))(( #|" sym "")) + +(def-sly-test symbol-at-point.12 (sym) + "fancy symbol-name wrapped in \"...\"" + sly-test-symbols + (sly-check-symbol-at-point "\"\n" sym "\"\n")) + +(def-sly-test symbol-at-point.13 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + sly-test-symbols + (sly-check-symbol-at-point "\" )))(( \"\n" sym "")) + +(def-sly-test symbol-at-point.14 (sym) + "fancy symbol-name wrapped in \" )))(( \" (1)" + sly-test-symbols + (sly-check-symbol-at-point "\" )))(( \"" sym "")) + +(def-sly-test symbol-at-point.15 (sym) + "symbol-at-point after #." + sly-test-symbols + (sly-check-symbol-at-point "#." sym "")) + +(def-sly-test symbol-at-point.16 (sym) + "symbol-at-point after #+" + sly-test-symbols + (sly-check-symbol-at-point "#+" sym "")) + + +(def-sly-test sexp-at-point.1 (string) + "symbol-at-point after #'" + '(("foo") + ("#:foo") + ("#'foo") + ("#'(lambda (x) x)") + ("()")) + (with-temp-buffer + (lisp-mode) + (insert string) + (goto-char (point-min)) + (sly-test-expect (format "Check sexp `%s' (at %d)..." + (buffer-string) (point)) + string + (sly-sexp-at-point) + #'equal))) + +(def-sly-test narrowing () + "Check that narrowing is properly sustained." + '() + (sly-check-top-level) + (let ((random-buffer-name (symbol-name (cl-gensym))) + (defun-pos) (tmpbuffer)) + (with-temp-buffer + (dotimes (i 100) (insert (format ";;; %d. line\n" i))) + (setq tmpbuffer (current-buffer)) + (setq defun-pos (point)) + (insert (concat "(defun __foo__ (x y)" "\n" + " 'nothing)" "\n")) + (dotimes (i 100) (insert (format ";;; %d. line\n" (+ 100 i)))) + (sly-check "Checking that newly created buffer is not narrowed." + (not (buffer-narrowed-p))) + + (goto-char defun-pos) + (narrow-to-defun) + (sly-check "Checking that narrowing succeeded." + (buffer-narrowed-p)) + + (sly-with-popup-buffer (random-buffer-name) + (sly-check ("Checking that we're in Sly's temp buffer `%s'" + random-buffer-name) + (equal (buffer-name (current-buffer)) random-buffer-name))) + (with-current-buffer random-buffer-name + ;; Notice that we cannot quit the buffer within the extent + ;; of sly-with-output-to-temp-buffer. + (quit-window t)) + (sly-check ("Checking that we've got back from `%s'" + random-buffer-name) + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (sly-check "Checking that narrowing sustained \ +after quitting Sly's temp buffer." + (buffer-narrowed-p)) + + (let ((sly-buffer-package "SLYNK") + (symbol '*buffer-package*)) + (sly-edit-definition (symbol-name symbol)) + (sly-check ("Checking that we've got M-. into slynk.lisp. %S" symbol) + (string= (file-name-nondirectory (buffer-file-name)) + "slynk.lisp")) + (sly-pop-find-definition-stack) + (sly-check ("Checking that we've got back.") + (and (eq (current-buffer) tmpbuffer) + (= (point) defun-pos))) + + (sly-check "Checking that narrowing sustained after M-," + (buffer-narrowed-p))) + )) + (sly-check-top-level)) + +(defun sly-test--pos-at-line (line) + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (line-beginning-position))) + +(def-sly-test recenter + (pos-line target expected-window-start) + "Test `sly-recenter'." + ;; numbers are actually lines numbers + '(;; region visible, point in region + (2 4 1) + ;; end not visible + (2 (+ wh 2) 2) + ;; end and start not visible + ((+ wh 2) (+ wh 500) (+ wh 2))) + (when noninteractive + (sly-skip-test "Can't test sly-recenter in batch mode")) + (with-temp-buffer + (cl-loop for i from 1 upto 1000 + do (insert (format "%09d\n" i))) + (let* ((win (display-buffer (current-buffer)))) + (cl-flet ((eval-with-wh (form) + (eval `(let ((wh ,(window-text-height win))) + ,form)))) + (with-selected-window win + (goto-char (sly-test--pos-at-line (eval-with-wh pos-line))) + (sly-recenter (sly-test--pos-at-line (eval-with-wh target))) + (redisplay) + (should (= (eval-with-wh expected-window-start) + (line-number-at-pos (window-start))))))))) + +(def-sly-test find-definition + (name buffer-package snippet) + "Find the definition of a function or macro in slynk.lisp." + '(("start-server" "SLYNK" "(defun start-server ") + ("slynk::start-server" "CL-USER" "(defun start-server ") + ("slynk:start-server" "CL-USER" "(defun start-server ") + ("slynk::connection" "CL-USER" "(defstruct (connection") + ("slynk::*emacs-connection*" "CL-USER" "(defvar \\*emacs-connection\\*") + ) + (switch-to-buffer "*scratch*") ; not buffer of definition + (sly-check-top-level) + (let ((orig-buffer (current-buffer)) + (orig-pos (point)) + (enable-local-variables nil) ; don't get stuck on -*- eval: -*- + (sly-buffer-package buffer-package)) + (sly-edit-definition name) + ;; Postconditions + (sly-check ("Definition of `%S' is in slynk.lisp." name) + (string= (file-name-nondirectory (buffer-file-name)) "slynk.lisp")) + (sly-check ("Looking at '%s'." snippet) (looking-at snippet)) + (sly-pop-find-definition-stack) + (sly-check "Returning from definition restores original buffer/position." + (and (eq orig-buffer (current-buffer)) + (= orig-pos (point))))) + (sly-check-top-level)) + +(def-sly-test (find-definition.2 (:fails-for "allegro" "lispworks")) + (buffer-content buffer-package snippet) + "Check that we're able to find definitions even when +confronted with nasty #.-fu." + '(("#.(prog1 nil (defvar *foobar* 42)) + + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SLYNK" + "[ \t]*(defun .foo. " + ) + ("#.(prog1 nil (defvar *foobar* 42)) + + ;; some comment + (defun .foo. (x) + (+ x #.*foobar*)) + + #.(prog1 nil (makunbound '*foobar*)) + " + "SLYNK" + "[ \t]*(defun .foo. " + ) + ("(in-package slynk) +(eval-when (:compile-toplevel) (defparameter *bar* 456)) +(eval-when (:load-toplevel :execute) (makunbound '*bar*)) +(defun bar () #.*bar*) +(defun .foo. () 123)" +"SLYNK" +"[ \t]*(defun .foo. () 123)")) + (let ((sly-buffer-package buffer-package)) + (with-temp-buffer + (insert buffer-content) + (sly-check-top-level) + (sly-eval + `(slynk:compile-string-for-emacs + ,buffer-content + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil)) + (let ((bufname (buffer-name))) + (sly-edit-definition ".foo.") + (sly-check ("Definition of `.foo.' is in buffer `%s'." bufname) + (string= (buffer-name) bufname)) + (sly-check "Definition now at point." (looking-at snippet))) + ))) + +(def-sly-test (find-definition.3 + (:fails-for "abcl" "allegro" "clisp" "lispworks" + ("sbcl" version< "1.3.0") + "ecl")) + (name source regexp) + "Extra tests for defstruct." + '(("slynk::foo-struct" + "(progn + (defun foo-fun ()) + (defstruct (foo-struct (:constructor nil) (:predicate nil))) +)" + "(defstruct (foo-struct")) + (switch-to-buffer "*scratch*") + (with-temp-buffer + (insert source) + (let ((sly-buffer-package "SLYNK")) + (sly-eval + `(slynk:compile-string-for-emacs + ,source + ,(buffer-name) + '((:position 0) (:line 1 1)) + ,nil + ,nil))) + (let ((temp-buffer (current-buffer))) + (with-current-buffer "*scratch*" + (sly-edit-definition name) + (sly-check ("Definition of %S is in buffer `%s'." + name temp-buffer) + (eq (current-buffer) temp-buffer)) + (sly-check "Definition now at point." (looking-at regexp))) + ))) + +(def-sly-test complete-symbol + (prefix expected-completions) + "Find the completions of a symbol-name prefix." + '(("cl:compile" (("cl:compile" "cl:compile-file" "cl:compile-file-pathname" + "cl:compiled-function" "cl:compiled-function-p" + "cl:compiler-macro" "cl:compiler-macro-function") + "cl:compile")) + ("cl:foobar" (nil "")) + ("slynk::compile-file" (("slynk::compile-file" + "slynk::compile-file-for-emacs" + "slynk::compile-file-if-needed" + "slynk::compile-file-output" + "slynk::compile-file-pathname") + "slynk::compile-file")) + ("cl:m-v-l" (nil ""))) + (let ((completions (sly-simple-completions prefix))) + (sly-test-expect "Completion set" expected-completions completions))) + +(def-sly-test flex-complete-symbol + (prefix expectations) + "Find the flex completions of a symbol-name prefix." + '(("m-v-b" (("multiple-value-bind" 1))) + ("mvbind" (("multiple-value-bind" 1))) + ("mvcall" (("multiple-value-call" 1))) + ("mvlist" (("multiple-value-list" 3))) + ("echonumberlist" (("slynk:*echo-number-alist*" 1)))) + (let* ((sly-buffer-package "COMMON-LISP") + (completions (car (sly-flex-completions prefix)))) + (cl-loop for (completion before-or-at) in expectations + for pos = (cl-position completion completions :test #'string=) + unless pos + do (ert-fail (format "Didn't find %s in the completions for %s" completion prefix)) + unless (< pos before-or-at) + do (ert-fail (format "Expected to find %s in the first %s completions for %s, but it came in %s +=> %s" + completion before-or-at prefix (1+ pos) + (cl-subseq completions 0 (1+ pos))))))) + +(def-sly-test basic-completion + (input-keys expected-result) + "Test `sly-read-from-minibuffer' with INPUT-KEYS as events." + '(("( r e v e TAB TAB SPC ' ( 1 SPC 2 SPC 3 ) ) RET" + "(reverse '(1 2 3))") + ("( c l : c o n TAB s t a n t l TAB TAB SPC 4 2 ) RET" + "(cl:constantly 42)")) + (when noninteractive + (sly-skip-test "Can't use unread-command-events in batch mode")) + (setq unread-command-events (listify-key-sequence (kbd input-keys))) + (let ((actual-result (sly-read-from-minibuffer "Test: "))) + (sly-test-expect "Completed string" expected-result actual-result))) + +(def-sly-test arglist + ;; N.B. Allegro apparently doesn't return the default values of + ;; optional parameters. Thus the regexp in the start-server + ;; expected value. In a perfect world we'd find a way to smooth + ;; over this difference between implementations--perhaps by + ;; convincing Franz to provide a function that does what we want. + (function-name expected-arglist) + "Lookup the argument list for FUNCTION-NAME. +Confirm that EXPECTED-ARGLIST is displayed." + '(("slynk::operator-arglist" "(slynk::operator-arglist name package)") + ("slynk::compute-backtrace" "(slynk::compute-backtrace start end)") + ("slynk::emacs-connected" "(slynk::emacs-connected)") + ("slynk::compile-string-for-emacs" + "(slynk::compile-string-for-emacs \ +string buffer position filename policy)") + ("slynk::connection-socket-io" + "(slynk::connection-socket-io \ +\\(struct\\(ure\\)?\\|object\\|instance\\|x\\|connection\\))") + ("cl:lisp-implementation-type" "(cl:lisp-implementation-type)") + ("cl:class-name" + "(cl:class-name \\(class\\|object\\|instance\\|structure\\))")) + (let ((arglist (sly-eval `(slynk:operator-arglist ,function-name + "slynk")))) + (sly-test-expect "Argument list is as expected" + expected-arglist (and arglist (downcase arglist)) + (lambda (pattern arglist) + (and arglist (string-match pattern arglist)))))) + +(defun sly-test--compile-defun (program subform) + (sly-check-top-level) + (with-temp-buffer + (lisp-mode) + (insert program) + (let ((font-lock-verbose nil)) + (setq sly-buffer-package ":slynk") + (sly-compile-string (buffer-string) 1) + (setq sly-buffer-package ":cl-user") + (sly-sync-to-top-level 5) + (goto-char (point-max)) + (call-interactively 'sly-previous-note) + (sly-check error-location-correct + (equal (read (current-buffer)) subform)))) + (sly-check-top-level)) + +(def-sly-test (compile-defun (:fails-for "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that the EXPECTED subform is correctly located." + '(("(defun cl-user::foo () (cl-user::bar))" (cl-user::bar)) + ("(defun cl-user::foo () + #\\space + ;;Sdf + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #+(or)skipped + #| #||# + #||# |# + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + \"\\\" bla bla \\\"\" + (cl-user::bar))" + (cl-user::bar)) + ("(defun cl-user::foo () + #.*log-events* + (cl-user::bar))" + (cl-user::bar)) + ("#.'(defun x () (/ 1 0)) + (defun foo () + (cl-user::bar)) + + " + (cl-user::bar))) + (sly-test--compile-defun program subform)) + +;; This test ideally would be collapsed into the previous +;; compile-defun test, but only 1 case fails for ccl--and that's here +(def-sly-test (compile-defun-with-reader-conditionals + (:fails-for "allegro" "lispworks" "clisp" "ccl")) + (program expected) + "Compile PROGRAM containing errors. +Confirm that the EXPECTED subform is correctly located." + '(("(defun foo () + #+#.'(:and) (/ 1 0))" + (/ 1 0))) + (sly-test--compile-defun program expected)) + +;; SBCL used to pass this one but since 1.2.2 the backquote/unquote +;; reader was changed. See +;; https://bugs.launchpad.net/sbcl/+bug/1361502 +(def-sly-test (compile-defun-with-backquote + (:fails-for "sbcl" "allegro" "lispworks" "clisp")) + (program subform) + "Compile PROGRAM containing errors. +Confirm that SUBFORM is correctly located." + '(("(defun cl-user::foo () + (list `(1 ,(random 10) 2 ,@(make-list (random 10)) 3 + ,(cl-user::bar))))" + (cl-user::bar))) + (sly-test--compile-defun program subform)) + +(def-sly-test (compile-file (:fails-for "allegro" "lispworks" "clisp")) + (string) + "Insert STRING in a file, and compile it." + `((,(pp-to-string '(defun foo () nil)))) + (let ((filename "/tmp/sly-tmp-file.lisp")) + (with-temp-file filename + (insert string)) + (let ((cell (cons nil nil))) + (sly-eval-async + `(slynk:compile-file-for-emacs ,filename nil) + (sly-rcurry (lambda (result cell) + (setcar cell t) + (setcdr cell result)) + cell)) + (sly-wait-condition "Compilation finished" (lambda () (car cell)) + 0.5) + (let ((result (cdr cell))) + (sly-check "Compilation successfull" + (eq (sly-compilation-result.successp result) t)))))) + +(def-sly-test utf-8-source + (input output) + "Source code containing utf-8 should work" + (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206") + ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046) + ;; 'utf-8) + (string (decode-coding-string bytes 'utf-8-unix))) + (cl-assert (equal bytes (encode-coding-string string 'utf-8-unix))) + (list (concat "(defun cl-user::foo () \"" string "\")") + string))) + (sly-eval `(cl:eval (cl:read-from-string ,input))) + (sly-test-expect "Eval result correct" + output (sly-eval '(cl-user::foo))) + (let ((cell (cons nil nil))) + (let ((hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell))) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (progn + (sly-compile-string input 0) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (sly-test-expect "Compile-string result correct" + output (sly-eval '(cl-user::foo)))) + (remove-hook 'sly-compilation-finished-hook hook)) + (let ((filename "/tmp/sly-tmp-file.lisp")) + (setcar cell nil) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (with-temp-buffer + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte t)) + (setq buffer-file-coding-system 'utf-8-unix) + (setq buffer-file-name filename) + (insert ";; -*- coding: utf-8-unix -*- \n") + (insert input) + (let ((coding-system-for-write 'utf-8-unix)) + (write-region nil nil filename nil t)) + (let ((sly-load-failed-fasl 'always)) + (sly-compile-and-load-file) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (sly-test-expect "Compile-file result correct" + output (sly-eval '(cl-user::foo)))) + (remove-hook 'sly-compilation-finished-hook hook) + (ignore-errors (delete-file filename))))))) + +(def-sly-test async-eval-debugging (depth) + "Test recursive debugging of asynchronous evaluation requests." + '((1) (2) (3)) + (let ((depth depth) + (debug-hook-max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sly-db-get-default-buffer) + (when (> sly-db-level debug-hook-max-depth) + (setq debug-hook-max-depth sly-db-level) + (if (= sly-db-level depth) + ;; We're at maximum recursion - time to unwind + (sly-db-quit) + ;; Going down - enter another recursive debug + ;; Recursively debug. + (sly-eval-async '(error)))))))) + (let ((sly-db-hook (cons debug-hook sly-db-hook))) + (sly-eval-async '(error)) + (sly-sync-to-top-level 5) + (sly-check ("Maximum depth reached (%S) is %S." + debug-hook-max-depth depth) + (= debug-hook-max-depth depth)))))) + +(def-sly-test unwind-to-previous-sly-db-level (level2 level1) + "Test recursive debugging and returning to lower SLY-DB levels." + '((2 1) (4 2)) + (sly-check-top-level) + (let ((level2 level2) + (level1 level1) + (state 'enter) + (max-depth 0)) + (let ((debug-hook + (lambda () + (with-current-buffer (sly-db-get-default-buffer) + (setq max-depth (max sly-db-level max-depth)) + (cl-ecase state + (enter + (cond ((= sly-db-level level2) + (setq state 'leave) + (sly-db-invoke-restart (sly-db-first-abort-restart))) + (t + (sly-eval-async `(cl:aref cl:nil ,sly-db-level))))) + (leave + (cond ((= sly-db-level level1) + (setq state 'ok) + (sly-db-quit)) + (t + (sly-db-invoke-restart (sly-db-first-abort-restart)) + )))))))) + (let ((sly-db-hook (cons debug-hook sly-db-hook))) + (sly-eval-async `(cl:aref cl:nil 0)) + (sly-sync-to-top-level 15) + (sly-check-top-level) + (sly-check ("Maximum depth reached (%S) is %S." max-depth level2) + (= max-depth level2)) + (sly-check ("Final state reached.") + (eq state 'ok)))))) + +(defun sly-db-first-abort-restart () + (let ((case-fold-search t)) + (cl-position-if (lambda (x) (string-match "abort" (car x))) sly-db-restarts))) + +(def-sly-test loop-interrupt-quit + () + "Test interrupting a loop." + '(()) + (sly-check-top-level) + (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (accept-process-output nil 1) + (sly-check "In eval state." (sly-busy-p)) + (sly-interrupt) + (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5) + (sly-check-top-level)) + +(def-sly-test loop-interrupt-continue-interrupt-quit + () + "Test interrupting a previously interrupted but continued loop." + '(()) + (sly-check-top-level) + (sly-eval-async '(cl:loop) (lambda (_) ) "CL-USER") + (sleep-for 1) + (sly-wait-condition "running" #'sly-busy-p 5) + (sly-interrupt) + (sly-wait-condition "First interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "running" (lambda () + (and (sly-busy-p) + (not (sly-db-get-default-buffer)))) 5) + (sly-interrupt) + (sly-wait-condition "Second interrupt" (lambda () (sly-sly-db-level= 1)) 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5) + (sly-check-top-level)) + +(def-sly-test interactive-eval + () + "Test interactive eval and continuing from the debugger." + '(()) + (sly-check-top-level) + (let ((sly-db-hook (lambda () + (sly-db-continue)))) + (sly-interactive-eval + "(progn\ + (cerror \"foo\" \"restart\")\ + (cerror \"bar\" \"restart\")\ + (+ 1 2))") + (sly-sync-to-top-level 5) + (current-message)) + (unless noninteractive + (should (equal "=> 3 (2 bits, #x3, #o3, #b11)" + (current-message))))) + +(def-sly-test report-condition-with-circular-list + (format-control format-argument) + "Test conditions involving circular lists." + '(("~a" "(let ((x (cons nil nil))) (setf (cdr x) x))") + ("~a" "(let ((x (cons nil nil))) (setf (car x) x))") + ("~a" "(let ((x (cons (make-string 100000 :initial-element #\\X) nil)))\ + (setf (cdr x) x))")) + (sly-check-top-level) + (let ((done nil)) + (let ((sly-db-hook (lambda () (sly-db-continue) (setq done t)))) + (sly-interactive-eval + (format "(with-standard-io-syntax (cerror \"foo\" \"%s\" %s) (+ 1 2))" + format-control format-argument)) + (while (not done) (accept-process-output)) + (sly-sync-to-top-level 5) + (sly-check-top-level) + (unless noninteractive + (let ((message (current-message))) + (sly-check "Minibuffer contains: \"3\"" + (equal "=> 3 (2 bits, #x3, #o3, #b11)" message))))))) + +(def-sly-test interrupt-bubbling-idiot + () + "Test interrupting a loop that sends a lot of output to Emacs." + '(()) + (accept-process-output nil 1) + (sly-check-top-level) + (sly-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i) + (cl:finish-output))) + (lambda (_) ) + "CL-USER") + (sleep-for 1) + (sly-interrupt) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 30) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5)) + +(def-sly-test (interrupt-encode-message (:style :sigio)) + () + "Test interrupt processing during slynk::encode-message" + '(()) + (sly-eval-async '(cl:loop :for i :from 0 + :do (slynk::background-message "foo ~d" i))) + (sleep-for 1) + (sly-eval-async '(cl:/ 1 0)) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 30) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5)) + +(def-sly-test inspector + (exp) + "Test basic inspector workingness." + '(((let ((h (make-hash-table))) + (loop for i below 10 do (setf (gethash i h) i)) + h)) + ((make-array 10)) + ((make-list 10)) + ('cons) + (#'cons)) + (sly-inspect (prin1-to-string exp)) + (cl-assert (not (sly-inspector-visible-p))) + (sly-wait-condition "Inspector visible" #'sly-inspector-visible-p 5) + (with-current-buffer (window-buffer (selected-window)) + (sly-inspector-quit)) + (sly-wait-condition "Inspector closed" + (lambda () (not (sly-inspector-visible-p))) + 5) + (sly-sync-to-top-level 1)) + +(defun sly-buffer-visible-p (name) + (let ((buffer (window-buffer (selected-window)))) + (string-match name (buffer-name buffer)))) + +(defun sly-inspector-visible-p () + (sly-buffer-visible-p (sly-buffer-name :inspector :connection t))) + +(defun sly-execute-as-command (name) + "Execute `name' as if it was done by the user through the +Command Loop. Similiar to `call-interactively' but also pushes on +the buffer's undo-list." + (undo-boundary) + (call-interactively name)) + +(def-sly-test macroexpand + (macro-defs bufcontent expansion1 search-str expansion2) + "foo" + '((("(defmacro qwertz (&body body) `(list :qwertz ',body))" + "(defmacro yxcv (&body body) `(list :yxcv (qwertz ,@body)))") + "(yxcv :A :B :C)" + "(list :yxcv (qwertz :a :b :c))" + "(qwertz" + "(list :yxcv (list :qwertz '(:a :b :c)))")) + (sly-check-top-level) + (setq sly-buffer-package ":slynk") + (with-temp-buffer + (lisp-mode) + (dolist (def macro-defs) + (sly-compile-string def 0) + (sly-sync-to-top-level 5)) + (insert bufcontent) + (goto-char (point-min)) + (sly-execute-as-command 'sly-macroexpand-1) + (sly-wait-condition "Macroexpansion buffer visible" + (lambda () + (sly-buffer-visible-p + (sly-buffer-name :macroexpansion))) + 5) + (with-current-buffer (get-buffer (sly-buffer-name :macroexpansion)) + (sly-test-expect "Initial macroexpansion is correct" + expansion1 + (downcase (buffer-string)) + #'sly-test-macroexpansion=) + (search-forward search-str) + (backward-up-list) + (sly-execute-as-command 'sly-macroexpand-1-inplace) + (sly-sync-to-top-level 3) + (sly-test-expect "In-place macroexpansion is correct" + expansion2 + (downcase (buffer-string)) + #'sly-test-macroexpansion=) + (sly-execute-as-command 'sly-macroexpand-undo) + (sly-test-expect "Expansion after undo is correct" + expansion1 + (downcase (buffer-string)) + #'sly-test-macroexpansion=))) + (setq sly-buffer-package ":cl-user")) + +(defun sly-test-macroexpansion= (string1 string2 &optional ignore-case) + (let ((string1 (replace-regexp-in-string " *\n *" " " string1)) + (string2 (replace-regexp-in-string " *\n *" " " string2))) + (compare-strings string1 nil nil + string2 nil nil + ignore-case))) + +(def-sly-test indentation (buffer-content point-markers) + "Check indentation update to work correctly." + '((" +\(in-package :slynk) + +\(defmacro with-lolipop (&body body) + `(progn ,@body)) + +\(defmacro lolipop (&body body) + `(progn ,@body)) + +\(with-lolipop + 1 + 2 + 42) + +\(lolipop + 1 + 2 + 23) +" + ("23" "42"))) + (with-temp-buffer + (lisp-mode) + (sly-editing-mode 1) + (insert buffer-content) + (sly-compile-region (point-min) (point-max)) + (sly-sync-to-top-level 3) + (sly-update-indentation) + (sly-sync-to-top-level 3) + (dolist (marker point-markers) + (search-backward marker) + (beginning-of-defun) + (indent-region (point) (progn (end-of-defun) (point)))) + (sly-test-expect "Correct buffer content" + buffer-content + (substring-no-properties (buffer-string))))) + +(def-sly-test break + (times exp) + "Test whether BREAK invokes SLY-DB." + (let ((exp1 '(break))) + `((1 ,exp1) (2 ,exp1) (3 ,exp1))) + (accept-process-output nil 0.2) + (sly-check-top-level) + (sly-eval-async + `(cl:eval (cl:read-from-string + ,(prin1-to-string `(dotimes (i ,times) + (unless (= i 0) + (slynk::sleep-for 1)) + ,exp))))) + (dotimes (_i times) + (sly-wait-condition "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window + (sly-db-get-default-buffer)))) + 3) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "sly-db closed" + (lambda () (not (sly-db-get-default-buffer))) + 0.5)) + (sly-sync-to-top-level 1)) + +(def-sly-test (break2 (:fails-for "cmucl" "allegro")) + (times exp) + "Backends should arguably make sure that BREAK does not depend +on *DEBUGGER-HOOK*." + (let ((exp2 + '(block outta + (let ((*debugger-hook* (lambda (c h) (return-from outta 42)))) + (break))))) + `((1 ,exp2) (2 ,exp2) (3 ,exp2))) + (sly-test-break times exp)) + +(def-sly-test locally-bound-debugger-hook + () + "Test that binding *DEBUGGER-HOOK* locally works properly." + '(()) + (accept-process-output nil 1) + (sly-check-top-level) + (sly-compile-string + (prin1-to-string `(defun cl-user::quux () + (block outta + (let ((*debugger-hook* + (lambda (c hook) + (declare (ignore c hook)) + (return-from outta 42)))) + (error "FOO"))))) + 0) + (sly-sync-to-top-level 2) + (sly-eval-async '(cl-user::quux)) + ;; FIXME: sly-wait-condition returns immediately if the test returns true + (sly-wait-condition "Checking that Debugger does not popup" + (lambda () + (not (sly-db-get-default-buffer))) + 3) + (sly-sync-to-top-level 5)) + +(def-sly-test end-of-file + (expr) + "Signalling END-OF-FILE should invoke the debugger." + '(((cl:read-from-string "")) + ((cl:error 'cl:end-of-file))) + (let ((value (sly-eval + `(cl:let ((condition nil)) + (cl:with-simple-restart + (cl:continue "continue") + (cl:let ((cl:*debugger-hook* + (cl:lambda (c h) + (cl:setq condition c) + (cl:continue)))) + ,expr)) + (cl:and (cl:typep condition 'cl:end-of-file)))))) + (sly-test-expect "Debugger invoked" t value))) + +(def-sly-test interrupt-at-toplevel + () + "Let's see what happens if we send a user interrupt at toplevel." + '(()) + (sly-check-top-level) + (unless (and (eq (sly-communication-style) :spawn) + (not (featurep 'sly-repl))) + (sly-interrupt) + (sly-wait-condition + "Debugger visible" + (lambda () + (and (sly-sly-db-level= 1) + (get-buffer-window (sly-db-get-default-buffer)))) + 5) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 5))) + +(def-sly-test interrupt-in-debugger (interrupts continues) + "Let's see what happens if we interrupt the debugger. +INTERRUPTS ... number of nested interrupts +CONTINUES ... how often the continue restart should be invoked" + '((1 0) (2 1) (4 2)) + (sly-check "No debugger" (not (sly-db-get-default-buffer))) + (when (and (eq (sly-communication-style) :spawn) + (not (featurep 'sly-repl))) + (sly-eval-async '(slynk::without-sly-interrupts + (slynk::receive))) + (sit-for 0.2)) + (dotimes (i interrupts) + (sly-interrupt) + (let ((level (1+ i))) + (sly-wait-condition (format "Debug level %d reachend" level) + (lambda () (equal (sly-db-level) level)) + 2))) + (dotimes (i continues) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (let ((level (- interrupts (1+ i)))) + (sly-wait-condition (format "Return to debug level %d" level) + (lambda () (equal (sly-db-level) level)) + 2))) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-quit)) + (sly-sync-to-top-level 1)) + +(def-sly-test flow-control + (n delay interrupts) + "Let Lisp produce output faster than Emacs can consume it." + `((300 0.03 3)) + (when noninteractive + (sly-skip-test "test is currently unstable")) + (sly-check "No debugger" (not (sly-db-get-default-buffer))) + (sly-eval-async `(slynk:flow-control-test ,n ,delay)) + (sleep-for 0.2) + (dotimes (_i interrupts) + (sly-interrupt) + (sly-wait-condition "In debugger" (lambda () (sly-sly-db-level= 1)) 5) + (sly-check "In debugger" (sly-sly-db-level= 1)) + (with-current-buffer (sly-db-get-default-buffer) + (sly-db-continue)) + (sly-wait-condition "No debugger" (lambda () (sly-sly-db-level= nil)) 3) + (sly-check "Debugger closed" (sly-sly-db-level= nil))) + (sly-sync-to-top-level 10)) + +(def-sly-test sbcl-world-lock + (n delay) + "Print something from *MACROEXPAND-HOOK*. +In SBCL, the compiler grabs a lock which can be problematic because +no method dispatch code can be generated for other threads. +This test will fail more likely before dispatch caches are warmed up." + '((10 0.03) + ;;((cl:+ slynk::send-counter-limit 10) 0.03) + ) + (sly-test-expect "no error" + 123 + (sly-eval + `(cl:let ((cl:*macroexpand-hook* + (cl:lambda (fun form env) + (slynk:flow-control-test ,n ,delay) + (cl:funcall fun form env)))) + (cl:eval '(cl:macrolet ((foo () 123)) + (foo))))))) + +(def-sly-test (disconnect-one-connection (:style :spawn)) () + "`sly-disconnect' should disconnect only the current connection" + '(()) + (let ((connection-count (length sly-net-processes)) + (old-connection sly-default-connection) + (sly-connected-hook nil)) + (unwind-protect + (let ((sly-dispatching-connection + (sly-connect "localhost" + ;; Here we assume that the request will + ;; be evaluated in its own thread. + (sly-eval `(slynk:create-server + :port 0 ; use random port + :style :spawn + :dont-close nil))))) + (sly-sync-to-top-level 3) + (sly-disconnect) + (sly-test-expect "Number of connections must remane the same" + connection-count + (length sly-net-processes))) + (sly-select-connection old-connection)))) + +(def-sly-test disconnect-and-reconnect + () + "Close the connetion. +Confirm that the subprocess continues gracefully. +Reconnect afterwards." + '(()) + (sly-check-top-level) + (let* ((c (sly-connection)) + (p (sly-inferior-process c))) + (with-current-buffer (process-buffer p) + (erase-buffer)) + (delete-process c) + (cl-assert (equal (process-status c) 'closed) nil "Connection not closed") + (accept-process-output nil 0.1) + (cl-assert (equal (process-status p) 'run) nil "Subprocess not running") + (with-current-buffer (process-buffer p) + (cl-assert (< (buffer-size) 500) nil "Unusual output")) + (sly-inferior-connect p (sly-inferior-lisp-args p)) + (let ((hook nil) (p p)) + (setq hook (lambda () + (sly-test-expect + "We are connected again" p (sly-inferior-process)) + (remove-hook 'sly-connected-hook hook))) + (add-hook 'sly-connected-hook hook) + (sly-wait-condition "Lisp restarted" + (lambda () + (not (member hook sly-connected-hook))) + 5)))) + + +;;;; SLY-loading tests that launch separate Emacsen +;;;; +(defvar sly-test-check-repl-forms + `((unless (and (featurep 'sly-mrepl) + (assq 'slynk/mrepl sly-contrib--required-slynk-modules)) + (die "`sly-repl' contrib not properly setup")) + (let ((mrepl-buffer (sly-mrepl--find-buffer))) + (unless mrepl-buffer + (die "MREPL buffer not setup!")) + (with-current-buffer mrepl-buffer + ;; FIXME: suboptimal: wait one second for the lisp + ;; to reply. + (sit-for 1) + (unless (and (string-match "^; +SLY" (buffer-string)) + (string-match "CL-USER> *$" (buffer-string))) + (die (format "MREPL prompt: %s" (buffer-string)))))))) + +(defvar sly-test-check-asdf-loader-forms + `((when (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) + (die "Didn't expect SLY to be loaded with slynk-loader.lisp")))) + +(cl-defun sly-test-recipe-test-for + (&key preflight + (takeoff `((call-interactively 'sly))) + (landing (append sly-test-check-repl-forms + sly-test-check-asdf-loader-forms))) + (let ((success nil) + (test-file (make-temp-file "sly-recipe-" nil ".el")) + (test-forms + `((require 'cl) + (labels + ((die (reason &optional more) + (princ reason) + (terpri) + (and more (pp more)) + (kill-emacs 254))) + (condition-case err + (progn ,@preflight + ,@takeoff + ,(when (null landing) '(kill-emacs 0)) + (add-hook + 'sly-connected-hook + #'(lambda () + (condition-case err + (progn + ,@landing + (kill-emacs 0)) + (error + (die "Unexpected error running landing forms" + err)))) + t)) + (error + (die "Unexpected error running preflight/takeoff forms" err))) + (with-timeout + (30 + (die "Timeout waiting for recipe test to finish.")) + (while t (sit-for 1))))))) + (unwind-protect + (progn + (with-temp-buffer + (mapc #'insert (mapcar #'pp-to-string test-forms)) + (write-file test-file)) + (with-temp-buffer + (let ((retval + (call-process (concat invocation-directory invocation-name) + nil (list t nil) nil + "-Q" "--batch" + "-l" test-file))) + (unless (= 0 retval) + (ert-fail (buffer-string))))) + (setq success t)) + (if success (delete-file test-file) + (message "Test failed: keeping %s for inspection" test-file))))) + +(define-sly-ert-test readme-recipe () + "Test the README.md's autoload recipe." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly-autoloads)))) + +(define-sly-ert-test traditional-recipe () + "Test the README.md's traditional recipe." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly) + (sly-setup '(sly-fancy))))) + +(define-sly-ert-test slynk-loader-fallback () + "Test `sly-init-using-slynk-loader'" + ;; TODO: another useful test would be to test + ;; `sly-init-using-asdf's fallback to slynk-loader.lisp." + (sly-test-recipe-test-for + :preflight `((add-to-list 'load-path ,sly-path) + (setq inferior-lisp-program ,inferior-lisp-program) + (require 'sly-autoloads) + (setq sly-contribs '(sly-fancy)) + (setq sly-init-function 'sly-init-using-slynk-loader) + (sly-setup '(sly-fancy))) + :landing `((unless (sly-eval '(cl:and (cl:find-package :slynk-loader) t)) + (die "Expected SLY to be loaded with slynk-loader.lisp")) + ,@sly-test-check-repl-forms))) + + +;;; xref recompilation +;;; +(defun sly-test--eval-now (string) + (cl-second (sly-eval `(slynk:eval-and-grab-output ,string)))) + +(def-sly-test (sly-recompile-all-xrefs (:fails-for "cmucl")) () + "Test recompilation of all references within an xref buffer." + '(()) + (let* ((cell (cons nil nil)) + (hook (sly-curry (lambda (cell &rest _) (setcar cell t)) cell)) + (filename (make-temp-file "sly-recompile-all-xrefs" nil ".lisp")) + (xref-buffer)) + (add-hook 'sly-compilation-finished-hook hook) + (unwind-protect + (with-temp-file filename + (set-visited-file-name filename) + (sly-test--eval-now "(defparameter slynk::*.var.* nil)") + (insert "(in-package :slynk) + (defun .fn1. ()) + (defun .fn2. () (.fn1.) #.*.var.*) + (defun .fn3. () (.fn1.) #.*.var.*)") + (save-buffer) + (sly-compile-and-load-file) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5) + (sly-test--eval-now "(setq *.var.* t)") + (setcar cell nil) + (sly-xref :calls ".fn1." + (lambda (&rest args) + (setq xref-buffer (apply #'sly-xref--show-results args)) + (setcar cell t))) + (sly-wait-condition "Xrefs computed and displayed" + (lambda () (car cell)) + 0.5) + (setcar cell nil) + (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") + (sly-test--eval-now "(.fn3.)")) + '("nil" "nil"))) + ;; Recompile now + ;; + (with-current-buffer xref-buffer + (sly-recompile-all-xrefs) + (sly-wait-condition "Compilation finished" + (lambda () (car cell)) + 0.5)) + (should (cl-equalp (list (sly-test--eval-now "(.fn2.)") + (sly-test--eval-now "(.fn3.)")) + '("T" "T")))) + (remove-hook 'sly-compilation-finished-hook hook) + (when xref-buffer + (kill-buffer xref-buffer))))) + + +;;; window management after M-. +;;; +(cl-defmacro sly-test--with-find-definition-window-checker (fn + (window-splits + total-windows + starting-buffer-sym + starting-window-sym) + &rest body) + (declare (indent 2)) + (let ((temp-frame-sym (cl-gensym "temp-frame-"))) + `(progn + (sly-check-top-level) + (let ((,temp-frame-sym nil)) + (unwind-protect + (progn + (setq ,temp-frame-sym (if noninteractive + (selected-frame) + (make-frame))) + ;; too large a frame will exhibit slightly different + ;; window-popping behaviour + (set-frame-width ,temp-frame-sym 100) + (set-frame-height ,temp-frame-sym 40) + (with-selected-frame ,temp-frame-sym + (with-temp-buffer + (delete-other-windows) + (switch-to-buffer (current-buffer)) + (let ((,starting-window-sym (selected-window)) + (,starting-buffer-sym (current-buffer))) + (dotimes (_i ,window-splits) + (split-window)) + (funcall ,fn "cl:print-object") + (should (= ,total-windows (length (window-list ,temp-frame-sym)))) + (with-current-buffer + (window-buffer (selected-window)) + (should (eq major-mode 'sly-xref-mode)) + (forward-line 1) + (sly-xref-goto)) + ,@body)))) + (unless noninteractive + (delete-frame ,temp-frame-sym t))))))) + +(def-sly-test find-definition-same-window (window-splits total-windows) + "Test `sly-edit-definition' windows" + '((0 2) + (1 2) + (2 3)) + (sly-test--with-find-definition-window-checker + 'sly-edit-definition + (window-splits + total-windows + temp-buffer + original-window) + (with-current-buffer + (window-buffer (selected-window)) + (should-not (eq temp-buffer (current-buffer))) + (should (eq (selected-window) original-window))) + (should (= (if (zerop window-splits) + 1 + total-windows) + (length (window-list (selected-frame))))))) + +(def-sly-test find-definition-other-window (window-splits total-windows) + "Test `sly-edit-definition-other-window' windows" + '((0 2) + (1 2) + (2 3)) + (sly-test--with-find-definition-window-checker + 'sly-edit-definition-other-window + (window-splits + total-windows + temp-buffer + original-window) + (with-current-buffer + (window-buffer (selected-window)) + (should (window-live-p original-window)) + (should (eq temp-buffer (window-buffer original-window))) + (should-not (eq (selected-window) original-window))) + (should (= total-windows + (length (window-list (selected-frame))))))) + + + +(provide 'sly-tests) blob - /dev/null blob + e8197d35145b7d01b6ba8efb3d7c6ad33c29620a (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/sly-autoloads.el @@ -0,0 +1,138 @@ +;;; sly-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from sly.el + +(define-obsolete-variable-alias 'sly-setup-contribs 'sly-contribs "\ +2.3.2") +(defvar sly-contribs '(sly-fancy) "\ +A list of contrib packages to load with SLY.") +(autoload 'sly-setup "sly" "\ +Have SLY load and use extension modules CONTRIBS. +CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) +symbols of `provide'd and `require'd Elisp libraries. + +If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise +it is set to CONTRIBS. + +However, after `require'ing LIB1, LIB2 ..., this command invokes +additional initialization steps associated with each element +LIB1, LIB2, which can theoretically be reverted by +`sly-disable-contrib.' + +Notably, one of the extra initialization steps is affecting the +value of `sly-required-modules' (which see) thus affecting the +libraries loaded in the Slynk servers. + +If SLY is currently connected to a Slynk and a contrib in +CONTRIBS has never been loaded, that Slynk is told to load the +associated Slynk extension module. + +To ensure that a particular contrib is loaded, use +`sly-enable-contrib' instead. + +(fn &optional CONTRIBS)" t) +(autoload 'sly-mode "sly" "\ +Minor mode for horizontal SLY functionality. + +This is a minor mode. If called interactively, toggle the `Sly mode' +mode. If the prefix argument is positive, enable the mode, and if it is +zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `sly-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(autoload 'sly-editing-mode "sly" "\ +Minor mode for editing `lisp-mode' buffers. + +This is a minor mode. If called interactively, toggle the `Sly-Editing +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `sly-editing-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(autoload 'sly "sly" "\ +Start a Lisp implementation and connect to it. + + COMMAND designates a the Lisp implementation to start as an +\"inferior\" process to the Emacs process. It is either a +pathname string pathname to a lisp executable, a list (EXECUTABLE +ARGS...), or a symbol indexing +`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding +`sly-net-coding-system'. + +Interactively, both COMMAND and CODING-SYSTEM are nil and the +prefix argument controls the precise behaviour: + +- With no prefix arg, try to automatically find a Lisp. First + consult `sly-command-switch-to-existing-lisp' and analyse open + connections to maybe switch to one of those. If a new lisp is + to be created, first lookup `sly-lisp-implementations', using + `sly-default-lisp' as a default strategy. Then try + `inferior-lisp-program' if it looks like it points to a valid + lisp. Failing that, guess the location of a lisp + implementation. + +- With a positive prefix arg (one C-u), prompt for a command + string that starts a Lisp implementation. + +- With a negative prefix arg (M-- M-x sly, for example) prompt + for a symbol indexing one of the entries in + `sly-lisp-implementations' + +(fn &optional COMMAND CODING-SYSTEM INTERACTIVE)" t) +(autoload 'sly-connect "sly" "\ +Connect to a running Slynk server. Return the connection. +With prefix arg, asks if all connections should be closed +before. + +(fn HOST PORT &optional CODING-SYSTEM INTERACTIVE-P)" t) +(autoload 'sly-hyperspec-lookup "sly" "\ +A wrapper for `hyperspec-lookup' + +(fn SYMBOL-NAME)" t) +(autoload 'sly-info "sly" "\ +Read SLY manual + +(fn FILE &optional NODE)" t) +(add-hook 'lisp-mode-hook 'sly-editing-mode) +(register-definition-prefixes "sly" '("define-sly-" "inferior-lisp-program" "make-sly-" "sly-" "topline")) + +;;; End of scraped data + +(provide 'sly-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; sly-autoloads.el ends here blob - /dev/null blob + ca61a033b395171a77a8bcf57a68b65def4f1e19 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/sly-pkg.el @@ -0,0 +1,8 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "sly" "20250522.2241" + "Sylvester the Cat's Common Lisp IDE." + '((emacs "24.3")) + :url "https://github.com/joaotavora/sly" + :commit "f13ceb762c306c77d5e87366713a2a1689bb5113" + :revdesc "f13ceb762c30" + :keywords '("languages" "lisp" "sly")) blob - /dev/null blob + cce8d95ccf746a8549ec048879838b2500e49f85 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/sly.el @@ -0,0 +1,7515 @@ +;;; sly.el --- Sylvester the Cat's Common Lisp IDE -*- lexical-binding: t; -*- + +;; Package-Version: 20250522.2241 +;; Package-Revision: f13ceb762c30 +;; URL: https://github.com/joaotavora/sly +;; Package-Requires: ((emacs "24.3")) +;; Keywords: languages, lisp, sly + +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller +;; Copyright (C) 2007,2008,2009 Helmut Eller, Tobias C. Rittweiler +;; Copyright (C) 2014 João Távora +;; For a detailed list of contributors, see the manual. + +;; This program 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 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see . + +;;; Commentary: +;; +;; _____ __ __ __ +;; / ___/ / / \ \/ / |\ _,,,---,,_ +;; \__ \ / / \ / /,`.-'`' -. ;-;;,_ +;; ___/ / / /___ / / |,4- ) )-,_..;\ ( `'-' +;; /____/ /_____/ /_/ '---''(_/--' `-'\_) +;; +;; +;; SLY is Sylvester the Cat's Common Lisp IDE. +;; +;; SLY is a direct fork of SLIME, and contains the following +;; improvements over it: +;; +;; * A full-featured REPL based on Emacs's `comint.el`; +;; * Live code annotations via a new `sly-stickers` contrib; +;; * Consistent button interface. Every Lisp object can be copied to the REPL; +;; * flex-style completion out-of-the-box, using Emacs's completion API. +;; Company, Helm, and others supported natively, no plugin required; +;; * Cleanly ASDF-loaded by default, including contribs, enabled out-of-the-box; +;; * Multiple inspectors and multiple REPLs; +;; * An interactive trace dialog with interactive objects. Copies function calls +;; to the REPL; +;; * "Presentations" replaced by interactive backreferences which +;; highlight the object and remain stable throughout the REPL session; +;; +;; SLY is a fork of SLIME. We track its bugfixes, particularly to the +;; implementation backends. All SLIME's familar features (debugger, +;; inspector, xref, etc...) are still available, with improved overall +;; UX. +;; +;; See the NEWS.md file (should be sitting alongside this file) for +;; more information + +;;; Code: + +(require 'cl-lib) + +(eval-and-compile + (if (version< emacs-version "24.3") + (error "Sly requires at least Emacs 24.3"))) + +(eval-and-compile + (or (require 'hyperspec nil t) + (require 'hyperspec "lib/hyperspec"))) +(require 'thingatpt) +(require 'comint) +(require 'pp) +(require 'easymenu) +(require 'arc-mode) +(require 'etags) +(require 'apropos) +(require 'bytecomp) ;; for `byte-compile-current-file' and +;; `sly-byte-compile-hotspots'. + +(require 'sly-common "lib/sly-common") +(require 'sly-messages "lib/sly-messages") +(require 'sly-buttons "lib/sly-buttons") +(require 'sly-completion "lib/sly-completion") + +(require 'gv) ; for gv--defsetter + +(eval-when-compile + (require 'compile) + (require 'gud)) + +(defvar sly-path nil + "Directory containing the SLY package. +This is used to load the supporting Common Lisp library, Slynk. +The default value is automatically computed from the location of the +Emacs Lisp package.") + +;; Determine `sly-path' at load time, regardless of filename (.el or +;; .elc) being loaded. +;; +(setq sly-path + (if load-file-name + (file-name-directory load-file-name) + (error "[sly] fatal: impossible to determine sly-path"))) + +(defun sly-slynk-path () + "Path where the bundled Slynk server is located." + (expand-file-name "slynk/" sly-path)) + +;;;###autoload +(define-obsolete-variable-alias 'sly-setup-contribs + 'sly-contribs "2.3.2") +;;;###autoload +(defvar sly-contribs '(sly-fancy) + "A list of contrib packages to load with SLY.") + +;;;###autoload +(defun sly-setup (&optional contribs) + "Have SLY load and use extension modules CONTRIBS. +CONTRIBS defaults to `sly-contribs' and is a list (LIB1 LIB2...) +symbols of `provide'd and `require'd Elisp libraries. + +If CONTRIBS is nil, `sly-contribs' is *not* affected, otherwise +it is set to CONTRIBS. + +However, after `require'ing LIB1, LIB2 ..., this command invokes +additional initialization steps associated with each element +LIB1, LIB2, which can theoretically be reverted by +`sly-disable-contrib.' + +Notably, one of the extra initialization steps is affecting the +value of `sly-required-modules' (which see) thus affecting the +libraries loaded in the Slynk servers. + +If SLY is currently connected to a Slynk and a contrib in +CONTRIBS has never been loaded, that Slynk is told to load the +associated Slynk extension module. + +To ensure that a particular contrib is loaded, use +`sly-enable-contrib' instead." + ;; FIXME: The contract should be like some hypothetical + ;; `sly-refresh-contribs' + ;; + (interactive) + (when contribs + (setq sly-contribs contribs)) + (sly--setup-contribs)) + +(defvaralias 'sly-required-modules 'sly-contrib--required-slynk-modules) + +(defvar sly-contrib--required-slynk-modules '() + "Alist of (MODULE . (WHERE CONTRIB)) for slynk-provided features. + +MODULE is a symbol naming a specific Slynk feature, WHERE is +the full pathname to the directory where the file(s) +providing the feature are found and CONTRIB is a symbol as found +in `sly-contribs.'") + +(cl-defmacro sly--contrib-safe (contrib &body body) + "Run BODY catching and resignalling any errors for CONTRIB" + (declare (indent 1)) + `(condition-case-unless-debug e + (progn + ,@body) + (error (sly-error "There's an error in %s: %s" + ,contrib + e)))) + +(defun sly--setup-contribs () + "Load and initialize contribs." + ;; active != enabled + ;; ^ ^ + ;; | | + ;; v v + ;; forgotten != disabled + (add-to-list 'load-path (expand-file-name "contrib" sly-path)) + (mapc (lambda (c) + (sly--contrib-safe c (require c))) + sly-contribs) + (let* ((all-active-contribs + ;; these are the contribs the user chose to activate + ;; + (mapcar #'sly-contrib--find-contrib + (cl-reduce #'append (mapcar #'sly-contrib--all-dependencies + sly-contribs)))) + (defined-but-forgotten-contribs + ;; "forgotten contribs" are the ones the chose not to + ;; activate but whose definitions we have seen + ;; + (cl-remove-if #'(lambda (contrib) + (memq contrib all-active-contribs)) + (sly-contrib--all-contribs)))) + ;; Disable any forgotten contribs that are enabled right now. + ;; + (cl-loop for to-disable in defined-but-forgotten-contribs + when (sly--contrib-safe to-disable + (sly-contrib--enabled-p to-disable)) + do (funcall (sly-contrib--disable to-disable))) + ;; Enable any active contrib that is *not* enabled right now. + ;; + (cl-loop for to-enable in all-active-contribs + unless (sly--contrib-safe to-enable + (sly-contrib--enabled-p to-enable)) + do (funcall (sly-contrib--enable to-enable))) + ;; Some contribs add stuff to `sly-mode-hook' or + ;; `sly-editing-hook', so make sure we re-run those hooks now. + (when all-active-contribs + (defvar sly-editing-mode) ;FIXME: Forward reference! + (cl-loop for buffer in (buffer-list) + do (with-current-buffer buffer + (when sly-editing-mode (sly-editing-mode 1))))))) + +(eval-and-compile + (defun sly-version (&optional interactive file) + "Read SLY's version of its own sly.el file. +If FILE is passed use that instead to discover the version." + (interactive "p") + (let ((version + (with-temp-buffer + (insert-file-contents + (or file + (expand-file-name "sly.el" sly-path)) + nil 0 200) + (and (search-forward-regexp + ";;[[:space:]]*Version:[[:space:]]*\\(.*\\)$" nil t) + (match-string 1))))) + (if interactive + (sly-message "SLY %s" version) + version)))) + +(defvar sly-protocol-version nil) + +(setq sly-protocol-version + ;; Compile the version string into the generated .elc file, but + ;; don't actualy affect `sly-protocol-version' until load-time. + ;; + (eval-when-compile (sly-version nil (or load-file-name + byte-compile-current-file)))) + + +;;;; Customize groups +;; +;;;;; sly + +(defgroup sly nil + "Interaction with the Superior Lisp Environment." + :prefix "sly-" + :group 'applications) + +;;;;; sly-ui + +(defgroup sly-ui nil + "Interaction with the Superior Lisp Environment." + :prefix "sly-" + :group 'sly) + +(defcustom sly-truncate-lines t + "Set `truncate-lines' in popup buffers. +This applies to buffers that present lines as rows of data, such as +debugger backtraces and apropos listings." + :type 'boolean + :group 'sly-ui) + +(defcustom sly-kill-without-query-p nil + "If non-nil, kill SLY processes without query when quitting Emacs. +This applies to the *inferior-lisp* buffer and the network connections." + :type 'boolean + :group 'sly-ui) + +;;;;; sly-lisp + +(defgroup sly-lisp nil + "Lisp server configuration." + :prefix "sly-" + :group 'sly) + +(defcustom sly-ignore-protocol-mismatches nil + "If non-nil, ignore protocol mismatches between SLY and Slynk. +Programatically, this variable can be let-bound around calls to +`sly' or `sly-connect'." + :type 'boolean + :group 'sly) + +(defcustom sly-init-function 'sly-init-using-asdf + "Function bootstrapping slynk on the remote. + +Value is a function of two arguments: SLYNK-PORTFILE and an +ingored argument for backward compatibility. Function should +return a string issuing very first commands issued by Sly to +the remote-connection process. Some time after this there should +be a port number ready in SLYNK-PORTFILE." + :type '(choice (const :tag "Use ASDF" + sly-init-using-asdf) + (const :tag "Use legacy slynk-loader.lisp" + sly-init-using-slynk-loader)) + :group 'sly-lisp) + +(define-obsolete-variable-alias 'sly-backend + 'sly-slynk-loader-backend "3.0") + +(defcustom sly-slynk-loader-backend "slynk-loader.lisp" + "The name of the slynk-loader that loads the Slynk server. +Only applicable if `sly-init-function' is set to +`sly-init-using-slynk-loader'. This name is interpreted +relative to the directory containing sly.el, but could also be +set to an absolute filename." + :type 'string + :group 'sly-lisp) + +(defcustom sly-connected-hook nil + "List of functions to call when SLY connects to Lisp." + :type 'hook + :group 'sly-lisp) + +(defcustom sly-enable-evaluate-in-emacs nil + "*If non-nil, the inferior Lisp can evaluate arbitrary forms in Emacs. +The default is nil, as this feature can be a security risk." + :type '(boolean) + :group 'sly-lisp) + +(defcustom sly-lisp-host "localhost" + "The default hostname (or IP address) to connect to." + :type 'string + :group 'sly-lisp) + +(defcustom sly-port 4005 + "Port to use as the default for `sly-connect'." + :type 'integer + :group 'sly-lisp) + +(defvar sly-connect-host-history (list sly-lisp-host)) +(defvar sly-connect-port-history (list (prin1-to-string sly-port))) + +(defvar sly-net-valid-coding-systems + '((iso-latin-1-unix nil "iso-latin-1-unix") + (iso-8859-1-unix nil "iso-latin-1-unix") + (binary nil "iso-latin-1-unix") + (utf-8-unix t "utf-8-unix") + (emacs-mule-unix t "emacs-mule-unix") + (euc-jp-unix t "euc-jp-unix")) + "A list of valid coding systems. +Each element is of the form: (NAME MULTIBYTEP CL-NAME)") + +(defun sly-find-coding-system (name) + "Return the coding system for the symbol NAME. +The result is either an element in `sly-net-valid-coding-systems' +of nil." + (let ((probe (assq name sly-net-valid-coding-systems))) + (when (and probe (if (fboundp 'check-coding-system) + (ignore-errors (check-coding-system (car probe))) + (eq (car probe) 'binary))) + probe))) + +(defcustom sly-net-coding-system + (car (cl-find-if 'sly-find-coding-system + sly-net-valid-coding-systems :key 'car)) + "Coding system used for network connections. +See also `sly-net-valid-coding-systems'." + :type (cons 'choice + (mapcar (lambda (x) + (list 'const (car x))) + sly-net-valid-coding-systems)) + :group 'sly-lisp) + +;;;;; sly-mode + +(defgroup sly-mode nil + "Settings for sly-mode Lisp source buffers." + :prefix "sly-" + :group 'sly) + +;;;;; sly-mode-faces + +(defgroup sly-mode-faces nil + "Faces in sly-mode source code buffers." + :prefix "sly-" + :group 'sly-mode) + +(defface sly-error-face + `((((class color) (background light)) + (:underline "tomato")) + (((class color) (background dark)) + (:underline "tomato")) + (t (:underline t))) + "Face for errors from the compiler." + :group 'sly-mode-faces) + +(defface sly-warning-face + `((((class color) (background light)) + (:underline "orange")) + (((class color) (background dark)) + (:underline "coral")) + (t (:underline t))) + "Face for warnings from the compiler." + :group 'sly-mode-faces) + +(defface sly-style-warning-face + `((((class color) (background light)) + (:underline "olive drab")) + (((class color) (background dark)) + (:underline "khaki")) + (t (:underline t))) + "Face for style-warnings from the compiler." + :group 'sly-mode-faces) + +(defface sly-note-face + `((((class color) (background light)) + (:underline "brown3")) + (((class color) (background dark)) + (:underline "light goldenrod")) + (t (:underline t))) + "Face for notes from the compiler." + :group 'sly-mode-faces) + +;;;;; sly-db + +(defgroup sly-debugger nil + "Backtrace options and fontification." + :prefix "sly-db-" + :group 'sly) + +(defmacro define-sly-db-faces (&rest faces) + "Define the set of SLY-DB faces. +Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES). +NAME is a symbol; the face will be called sly-db-NAME-face. +DESCRIPTION is a one-liner for the customization buffer. +PROPERTIES specifies any default face properties." + `(progn ,@(cl-loop for face in faces + collect `(define-sly-db-face ,@face)))) + +(defmacro define-sly-db-face (name description &optional default) + (let ((facename (intern (format "sly-db-%s-face" (symbol-name name))))) + `(defface ,facename + (list (list t ,default)) + ,(format "Face for %s." description) + :group 'sly-debugger))) + +(define-sly-db-faces + (topline "the top line describing the error") + (condition "the condition class" '(:inherit error)) + (section "the labels of major sections in the debugger buffer" + '(:inherit header-line)) + (frame-label "backtrace frame numbers" + '(:inherit shadow)) + (restart "restart descriptions") + (restart-number "restart numbers (correspond to keystrokes to invoke)" + '(:inherit shadow)) + (frame-line "function names and arguments in the backtrace") + (restartable-frame-line + "frames which are surely restartable" + '(:inherit font-lock-constant-face)) + (non-restartable-frame-line + "frames which are surely not restartable") + (local-name "local variable names") + (catch-tag "catch tags")) + + +;;;;; Key bindings +(defvar sly-doc-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-a") 'sly-apropos) + (define-key map (kbd "C-z") 'sly-apropos-all) + (define-key map (kbd "C-p") 'sly-apropos-package) + (define-key map (kbd "C-d") 'sly-describe-symbol) + (define-key map (kbd "C-f") 'sly-describe-function) + (define-key map (kbd "C-h") 'sly-documentation-lookup) + (define-key map (kbd "~") 'common-lisp-hyperspec-format) + (define-key map (kbd "C-g") 'common-lisp-hyperspec-glossary-term) + (define-key map (kbd "#") 'common-lisp-hyperspec-lookup-reader-macro) + map)) + +(defvar sly-who-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c") 'sly-who-calls) + (define-key map (kbd "C-w") 'sly-calls-who) + (define-key map (kbd "C-r") 'sly-who-references) + (define-key map (kbd "C-b") 'sly-who-binds) + (define-key map (kbd "C-s") 'sly-who-sets) + (define-key map (kbd "C-m") 'sly-who-macroexpands) + (define-key map (kbd "C-a") 'sly-who-specializes) + map)) + +(defvar sly-selector-map (let ((map (make-sparse-keymap))) + (define-key map "c" 'sly-list-connections) + (define-key map "t" 'sly-list-threads) + (define-key map "d" 'sly-db-pop-to-debugger-maybe) + (define-key map "e" 'sly-pop-to-events-buffer) + (define-key map "i" 'sly-inferior-lisp-buffer) + (define-key map "l" 'sly-switch-to-most-recent) + map) + "A keymap for frequently used SLY shortcuts. +Access to this keymap can be installed in in +`sly-mode-map', using something like + + (global-set-key (kbd \"C-z\") sly-selector-map) + +This will bind C-z to this prefix map, one keystroke away from +the available shortcuts: + +\\{sly-selector-map} +As usual, users or extensions can plug in +any command into it using + + (define-key sly-selector-map (kbd \"k\") 'sly-command) + +Where \"k\" is the key to bind and \"sly-command\" is any +interactive command.\".") + +(defvar sly-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-r") 'sly-eval-region) + (define-key map (kbd ":") 'sly-interactive-eval) + (define-key map (kbd "C-e") 'sly-interactive-eval) + (define-key map (kbd "E") 'sly-edit-value) + (define-key map (kbd "C-l") 'sly-load-file) + (define-key map (kbd "C-b") 'sly-interrupt) + (define-key map (kbd "M-d") 'sly-disassemble-symbol) + (define-key map (kbd "C-t") 'sly-toggle-trace-fdefinition) + (define-key map (kbd "I") 'sly-inspect) + (define-key map (kbd "C-x t") 'sly-list-threads) + (define-key map (kbd "C-x n") 'sly-next-connection) + (define-key map (kbd "C-x c") 'sly-list-connections) + (define-key map (kbd "C-x p") 'sly-prev-connection) + (define-key map (kbd "<") 'sly-list-callers) + (define-key map (kbd ">") 'sly-list-callees) + ;; Include DOC keys... + (define-key map (kbd "C-d") sly-doc-map) + ;; Include XREF WHO-FOO keys... + (define-key map (kbd "C-w") sly-who-map) + ;; `sly-selector-map' used to be bound to "C-c C-s" by default, + ;; but sly-stickers has a better binding for that. + ;; + ;; (define-key map (kbd "C-s") sly-selector-map) + map)) + +(defvar sly-mode-map + (let ((map (make-sparse-keymap))) + ;; These used to be a `sly-parent-map' + (define-key map (kbd "M-.") 'sly-edit-definition) + (define-key map (kbd "M-,") 'sly-pop-find-definition-stack) + (define-key map (kbd "M-_") 'sly-edit-uses) ; for German layout + (define-key map (kbd "M-?") 'sly-edit-uses) ; for USian layout + (define-key map (kbd "C-x 4 .") 'sly-edit-definition-other-window) + (define-key map (kbd "C-x 5 .") 'sly-edit-definition-other-frame) + (define-key map (kbd "C-x C-e") 'sly-eval-last-expression) + (define-key map (kbd "C-M-x") 'sly-eval-defun) + ;; Include PREFIX keys... + (define-key map (kbd "C-c") sly-prefix-map) + ;; Completion + (define-key map (kbd "C-c TAB") 'completion-at-point) + ;; Evaluating + (define-key map (kbd "C-c C-p") 'sly-pprint-eval-last-expression) + ;; Macroexpand + (define-key map (kbd "C-c C-m") 'sly-expand-1) + (define-key map (kbd "C-c M-m") 'sly-macroexpand-all) + ;; Misc + (define-key map (kbd "C-c C-u") 'sly-undefine-function) + map)) + +(defvar sly-editing-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-p") 'sly-previous-note) + (define-key map (kbd "M-n") 'sly-next-note) + (define-key map (kbd "C-c M-c") 'sly-remove-notes) + (define-key map (kbd "C-c C-k") 'sly-compile-and-load-file) + (define-key map (kbd "C-c M-k") 'sly-compile-file) + (define-key map (kbd "C-c C-c") 'sly-compile-defun) + map)) + +(defvar sly-popup-buffer-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "q") 'quit-window) + map)) + + +;;;; Minor modes + +;;;;; sly-mode +(defvar sly-buffer-connection) +(defvar sly-dispatching-connection) +(defvar sly-current-thread) + +;; exceptional forward decl +(defvar company-tooltip-align-annotations) + +;;;###autoload +(define-minor-mode sly-mode + "Minor mode for horizontal SLY functionality." + nil nil nil + ;; Company-mode should have this by default + ;; See gh#166 + (set (make-local-variable 'company-tooltip-align-annotations) t)) + +(defun sly--lisp-indent-function (&rest args) + (let ((fn (if (fboundp 'sly-common-lisp-indent-function) + #'sly-common-lisp-indent-function + #'lisp-indent-function))) + (apply fn args))) + +;;;###autoload +(define-minor-mode sly-editing-mode + "Minor mode for editing `lisp-mode' buffers." + nil nil nil + (sly-mode 1) + (setq-local lisp-indent-function #'sly--lisp-indent-function)) + +(define-minor-mode sly-popup-buffer-mode + "Minor mode for all read-only SLY buffers" + nil nil nil + (sly-mode 1) + (sly-interactive-buttons-mode 1) + (setq buffer-read-only t)) + + +;;;;;; Mode-Line +(defface sly-mode-line + '((t (:inherit font-lock-constant-face + :weight bold))) + "Face for package-name in SLY's mode line." + :group 'sly) + +(defvar sly--mode-line-format `(:eval (sly--mode-line-format))) + +(put 'sly--mode-line-format 'risky-local-variable t) + +(defvar sly-menu) ;; forward referenced + +(defvar sly-extra-mode-line-constructs nil + "A list of mode-line constructs to add to SLY's mode-line. +Each construct is separated by a \"/\" and may be a regular +mode-line construct or a symbol naming a function of no arguments +that returns one such construct.") + +(defun sly--mode-line-format () + (let* ((conn (sly-current-connection)) + (conn (and (process-live-p conn) conn)) + (name (or (and conn + (sly-connection-name conn)) + "*")) + (pkg (sly-current-package)) + (format-number (lambda (n) (cond ((and n (not (zerop n))) + (format "%d" n)) + (n "-") + (t "*")))) + (package-name (and pkg + (sly--pretty-package-name pkg))) + (pending (and conn + (length (sly-rex-continuations conn)))) + (sly-dbs (and conn (length (sly-db-buffers conn))))) + `((:propertize "sly" + face sly-mode-line + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line down-mouse-1] + sly-menu) + map) + mouse-face mode-line-highlight + help-echo "mouse-1: pop-up SLY menu" + ) + " " + (:propertize ,name + face sly-mode-line + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-prev-connection) + (define-key map [mode-line mouse-2] 'sly-list-connections) + (define-key map [mode-line mouse-3] 'sly-next-connection) + map) + mouse-face mode-line-highlight + help-echo ,(concat "mouse-1: previous connection\n" + "mouse-2: list connections\n" + "mouse-3: next connection")) + "/" + ,(or package-name "*") + "/" + (:propertize ,(funcall format-number pending) + help-echo ,(if conn (format "%s pending events outgoing\n%s" + pending + (concat "mouse-1: go to *sly-events* buffer" + "mouse-3: forget pending continuations")) + "No current connection") + mouse-face mode-line-highlight + face ,(cond ((and pending (cl-plusp pending)) + 'warning) + (t + 'sly-mode-line)) + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-pop-to-events-buffer) + (define-key map [mode-line mouse-3] 'sly-forget-pending-events) + map)) + "/" + (:propertize ,(funcall format-number sly-dbs) + help-echo ,(if conn (format "%s SLY-DB buffers waiting\n%s" + pending + "mouse-1: go to first one") + "No current connection") + mouse-face mode-line-highlight + face ,(cond ((and sly-dbs (cl-plusp sly-dbs)) + 'warning) + (t + 'sly-mode-line)) + keymap ,(let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'sly-db-pop-to-debugger) + map)) + ,@(cl-loop for construct in sly-extra-mode-line-constructs + collect "/" + collect (if (and (symbolp construct) + (fboundp construct)) + (condition-case _oops + (funcall construct) + (error "*sly-invalid*")) + construct))))) + +(defun sly--refresh-mode-line () + (force-mode-line-update t)) + +(defun sly--pretty-package-name (name) + "Return a pretty version of a package name NAME." + (cond ((string-match "^#?:\\(.*\\)$" name) + (match-string 1 name)) + ((string-match "^\"\\(.*\\)\"$" name) + (match-string 1 name)) + (t name))) + +(add-to-list 'mode-line-misc-info + `(sly-mode (" [" sly--mode-line-format "] "))) + + +;;;; Framework'ey bits +;;; +;;; This section contains some standard SLY idioms: basic macros, +;;; ways of showing messages to the user, etc. All the code in this +;;; file should use these functions when applicable. +;;; +;;;;; Syntactic sugar + +(cl-defmacro sly--when-let ((var value) &rest body) + "Evaluate VALUE, if the result is non-nil bind it to VAR and eval BODY. + +\(fn (VAR VALUE) &rest BODY)" + (declare (indent 1)) + `(let ((,var ,value)) + (when ,var ,@body))) + +(cl-defmacro sly--when-let* (bindings &rest body) + "Same as `sly--when-let', but for multiple BINDINGS" + (declare (indent 1)) + (if bindings + `(sly--when-let ,(car bindings) + (sly--when-let* ,(cdr bindings) ,@body)) + `(progn ,@body))) + +(defmacro sly-dcase (value &rest patterns) + (declare (indent 1) + (debug (sexp &rest (sexp &rest form)))) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (cl-gensym "op-")) + (operands (cl-gensym "rand-")) + (tmp (cl-gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (cl-case ,operator + ,@(mapcar (lambda (clause) + (if (eq (car clause) t) + `(t ,@(cdr clause)) + (cl-destructuring-bind ((op &rest rands) &rest body) + clause + `(,op (cl-destructuring-bind ,rands ,operands + . ,(or body + '((ignore)) ; suppress some warnings + )))))) + patterns) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (sly-error "Elisp sly-dcase failed: %S" ,tmp)))))))) + +;;;;; Very-commonly-used functions + +;; Interface +(cl-defun sly-buffer-name (type &key connection hidden suffix) + (cl-assert (keywordp type)) + (mapconcat #'identity + `(,@(if hidden `(" ")) + "*sly-" + ,(downcase (substring (symbol-name type) 1)) + ,@(if connection + `(" for " + ,(sly-connection-name + (if (eq connection t) + (sly-current-connection) + connection)))) + ,@(if suffix + `(" (" + ,suffix + ")")) + "*") + "")) + +(defun sly-recenter (target &optional move-point) + "Make the region between point and TARGET visible. +Minimize window motion if possible. If MOVE-POINT allow point to +move to make TARGET visible." + (unless (pos-visible-in-window-p target) + (redisplay) + (let ((screen-line (- (line-number-at-pos) + (line-number-at-pos (window-start)))) + (window-end (line-number-at-pos (window-end))) + (window-start (line-number-at-pos (window-start))) + (target-line (line-number-at-pos target)) + recenter-arg) + (cond ((> (point) target) + (setq recenter-arg (+ screen-line (- window-start target-line))) + (if (or (not move-point) + (<= recenter-arg (window-height))) + (recenter recenter-arg) + (goto-char target) + (recenter -1) + (move-to-window-line -1))) + ((<= (point) target) + (setq recenter-arg (- screen-line (- target-line window-end))) + (if (or (not move-point) + (> recenter-arg 0)) + (recenter (max recenter-arg 0)) + (goto-char target) + (recenter 0) + (move-to-window-line 0))))))) + +;; Interface +(defun sly-set-truncate-lines () + "Apply `sly-truncate-lines' to the current buffer." + (when sly-truncate-lines + (set (make-local-variable 'truncate-lines) t))) + +;; Interface +(defun sly-read-package-name (prompt &optional initial-value allow-blank) + "Read a package name from the minibuffer, prompting with PROMPT. +If ALLOW-BLANK may return nil to signal no particular package +selected." + (let* ((completion-ignore-case t) + (res (completing-read + (concat "[sly] " prompt) + (sly-eval + `(slynk:list-all-package-names t)) + nil (not allow-blank) initial-value))) + (unless (zerop (length res)) + res))) + +;; Interface +(defmacro sly-propertize-region (props &rest body) + "Execute BODY and add PROPS to all the text it inserts. +More precisely, PROPS are added to the region between the point's +positions before and after executing BODY." + (declare (indent 1) (debug (sexp &rest form))) + (let ((start (cl-gensym))) + `(let ((,start (point))) + (prog1 (progn ,@body) + (add-text-properties ,start (point) ,props))))) + +(defun sly-add-face (face string) + (declare (indent 1)) + (add-text-properties 0 (length string) (list 'face face) string) + string) + +;; Interface +(defsubst sly-insert-propertized (props &rest args) + "Insert all ARGS and then add text-PROPS to the inserted text." + (sly-propertize-region props (apply #'insert args))) + +(defmacro sly-with-rigid-indentation (level &rest body) + "Execute BODY and then rigidly indent its text insertions. +Assumes all insertions are made at point." + (declare (indent 1)) + (let ((start (cl-gensym)) (l (cl-gensym))) + `(let ((,start (point)) (,l ,(or level '(current-column)))) + (prog1 (progn ,@body) + (sly-indent-rigidly ,start (point) ,l))))) + +(defun sly-indent-rigidly (start end column) + ;; Similar to `indent-rigidly' but doesn't inherit text props. + (let ((indent (make-string column ?\ ))) + (save-excursion + (goto-char end) + (beginning-of-line) + (while (and (<= start (point)) + (progn + (insert-before-markers indent) + (zerop (forward-line -1)))))))) + +(defun sly-insert-indented (&rest strings) + "Insert all arguments rigidly indented." + (sly-with-rigid-indentation nil + (apply #'insert strings))) + +(defun sly-compose (&rest functions) + "Compose unary FUNCTIONS right-associatively, returning a function" + #'(lambda (x) + (cl-reduce #'funcall functions :initial-value x :from-end t))) + +(defun sly-curry (fun &rest args) + "Partially apply FUN to ARGS. The result is a new function." + (lambda (&rest more) (apply fun (append args more)))) + +(defun sly-rcurry (fun &rest args) + "Like `sly-curry' but ARGS on the right are applied." + (lambda (&rest more) (apply fun (append more args)))) + + +;;;;; Temporary popup buffers + +;; keep compiler quiet +(defvar sly-buffer-package) +(defvar sly-buffer-connection) + + +;; Interface +(cl-defmacro sly-with-popup-buffer ((name &key package connection select + same-window-p + mode) + &body body) + "Similar to `with-output-to-temp-buffer'. +Bind standard-output and initialize some buffer-local variables. +Restore window configuration when closed. NAME is the name of +the buffer to be created. PACKAGE is the value +`sly-buffer-package'. CONNECTION is the value for +`sly-buffer-connection', if nil, no explicit connection is +associated with the buffer. If t, the current connection is +taken. MODE is the name of a major mode which will be enabled. +Non-nil SELECT indicates the buffer should be switched to, unless +it is `:hidden' meaning the buffer should not even be +displayed. SELECT can also be `:raise' meaning the buffer should +be switched to and the frame raised. SAME-WINDOW-P is a form +indicating if the popup *can* happen in the same window. The +forms SELECT and SAME-WINDOW-P are evaluated at runtime, not +macroexpansion time. +" + (declare (indent 1) + (debug (sexp &rest form))) + (let* ((package-sym (cl-gensym "package-")) + (connection-sym (cl-gensym "connection-")) + (select-sym (cl-gensym "select")) + (major-mode-sym (cl-gensym "select"))) + `(let ((,package-sym ,(if (eq package t) + `(sly-current-package) + package)) + (,connection-sym ,(if (eq connection t) + `(sly-current-connection) + connection)) + (,major-mode-sym major-mode) + (,select-sym ,select) + (view-read-only nil)) + (with-current-buffer (get-buffer-create ,name) + (let ((inhibit-read-only t) + (standard-output (current-buffer))) + (erase-buffer) + ,@(cond (mode + `((funcall ,mode))) + (t + `((sly-popup-buffer-mode 1)))) + (setq sly-buffer-package ,package-sym + sly-buffer-connection ,connection-sym) + (set-syntax-table lisp-mode-syntax-table) + ,@body + (unless (eq ,select-sym :hidden) + (let ((window (display-buffer + (current-buffer) + (if ,(cond (same-window-p same-window-p) + (mode `(eq ,major-mode-sym ,mode))) + nil + t)))) + (when ,select-sym + (if window + (select-window window t)))) + (if (eq ,select-sym :raise) (raise-frame))) + (current-buffer)))))) + +;;;;; Filename translation +;;; +;;; Filenames passed between Emacs and Lisp should be translated using +;;; these functions. This way users who run Emacs and Lisp on separate +;;; machines have a chance to integrate file operations somehow. + +(defvar sly-to-lisp-filename-function #'convert-standard-filename + "Function to translate Emacs filenames to CL namestrings.") +(defvar sly-from-lisp-filename-function #'identity + "Function to translate CL namestrings to Emacs filenames.") + +(defun sly-to-lisp-filename (filename) + "Translate the string FILENAME to a Lisp filename." + (funcall sly-to-lisp-filename-function (substring-no-properties filename))) + +(defun sly-from-lisp-filename (filename) + "Translate the Lisp filename FILENAME to an Emacs filename." + (funcall sly-from-lisp-filename-function filename)) + + +;;;; Starting SLY +;;; +;;; This section covers starting an inferior-lisp, compiling and +;;; starting the server, initiating a network connection. + +;;;;; Entry points + +;; We no longer load inf-lisp, but we use this variable for backward +;; compatibility. +(defcustom inferior-lisp-program "lisp" + "Program name for starting a Lisp subprocess to Emacs. +Can be a string naming a program, a whitespace-separated string +of \"EXECUTABLE ARG1 ARG2\" or a list (EXECUTABLE ARGS...) where +EXECUTABLE and ARGS are strings." + :type 'string + :group 'sly-lisp) + +(defvar sly-lisp-implementations nil + "*A list of known Lisp implementations. +The list should have the form: + ((NAME (PROGRAM PROGRAM-ARGS...) &key KEYWORD-ARGS) ...) + +NAME is a symbol for the implementation. +PROGRAM and PROGRAM-ARGS are strings used to start the Lisp process. +For KEYWORD-ARGS see `sly-start'. + +Here's an example: + ((cmucl (\"/opt/cmucl/bin/lisp\" \"-quiet\") :init sly-init-command) + (acl (\"acl7\") :coding-system emacs-mule))") + +(defcustom sly-command-switch-to-existing-lisp 'ask + "Should the `sly' command start new lisp if one is available?" + :type '(choice (const :tag "Ask the user" ask) + (const :tag "Always" 'always) + (const :tag "Never" 'never))) + +(defcustom sly-auto-select-connection 'ask + "Controls auto selection after the default connection was closed." + :group 'sly-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defcustom sly-default-lisp nil + "A symbol naming the preferred Lisp implementation. +See `sly-lisp-implementations'" + :type 'function + :group 'sly-mode) + +;; dummy definitions for the compiler +(defvar sly-net-processes) +(defvar sly-default-connection) + +;;;###autoload +(cl-defun sly (&optional command coding-system interactive) + "Start a Lisp implementation and connect to it. + + COMMAND designates a the Lisp implementation to start as an +\"inferior\" process to the Emacs process. It is either a +pathname string pathname to a lisp executable, a list (EXECUTABLE +ARGS...), or a symbol indexing +`sly-lisp-implementations'. CODING-SYSTEM is a symbol overriding +`sly-net-coding-system'. + +Interactively, both COMMAND and CODING-SYSTEM are nil and the +prefix argument controls the precise behaviour: + +- With no prefix arg, try to automatically find a Lisp. First + consult `sly-command-switch-to-existing-lisp' and analyse open + connections to maybe switch to one of those. If a new lisp is + to be created, first lookup `sly-lisp-implementations', using + `sly-default-lisp' as a default strategy. Then try + `inferior-lisp-program' if it looks like it points to a valid + lisp. Failing that, guess the location of a lisp + implementation. + +- With a positive prefix arg (one C-u), prompt for a command + string that starts a Lisp implementation. + +- With a negative prefix arg (M-- M-x sly, for example) prompt + for a symbol indexing one of the entries in + `sly-lisp-implementations'" + (interactive (list nil nil t)) + (sly--when-let* + ((active (and interactive + (not current-prefix-arg) + (sly--purge-connections))) + (target (or (and (eq sly-command-switch-to-existing-lisp 'ask) + (sly-prompt-for-connection + "[sly] Switch to open connection?\n\ + (Customize `sly-command-switch-to-existing-lisp' to avoid this prompt.)\n\ + Connections: " nil "(start a new one)")) + (and (eq sly-command-switch-to-existing-lisp 'always) + (car active))))) + (sly-message "Switching to `%s'" (sly-connection-name target)) + (sly-connection-list-default-action target) + (cl-return-from sly nil)) + (let ((command (or command inferior-lisp-program)) + (sly-net-coding-system (or coding-system sly-net-coding-system))) + (apply #'sly-start + (cond (interactive + (sly--read-interactive-args)) + (t + (if sly-lisp-implementations + (sly--lookup-lisp-implementation + sly-lisp-implementations + (or (and (symbolp command) command) + sly-default-lisp + (car (car sly-lisp-implementations)))) + (let ((command-and-args (if (listp command) + command + (split-string command)))) + `(:program ,(car command-and-args) + :program-args ,(cdr command-and-args))))))))) + +(defvar sly-inferior-lisp-program-history '() + "History list of command strings. Used by M-x sly.") + +(defun sly--read-interactive-args () + "Return the list of args which should be passed to `sly-start'. +Helper for M-x sly" + (cond ((not current-prefix-arg) + (cond (sly-lisp-implementations + (sly--lookup-lisp-implementation sly-lisp-implementations + (or sly-default-lisp + (car (car sly-lisp-implementations))))) + (t (cl-destructuring-bind (program &rest args) + (split-string-and-unquote + (sly--guess-inferior-lisp-program t)) + (list :program program :program-args args))))) + ((eq current-prefix-arg '-) + (let ((key (completing-read + "Lisp name: " (mapcar (lambda (x) + (list (symbol-name (car x)))) + sly-lisp-implementations) + nil t))) + (sly--lookup-lisp-implementation sly-lisp-implementations (intern key)))) + (t + (cl-destructuring-bind (program &rest program-args) + (split-string-and-unquote + (read-shell-command "[sly] Run lisp: " + (sly--guess-inferior-lisp-program nil) + 'sly-inferior-lisp-program-history)) + (let ((coding-system + (if (eq 16 (prefix-numeric-value current-prefix-arg)) + (read-coding-system "[sly] Set sly-coding-system: " + sly-net-coding-system) + sly-net-coding-system))) + (list :program program :program-args program-args + :coding-system coding-system)))))) + + +(defun sly--lookup-lisp-implementation (table name) + (let ((arguments (cl-rest (assoc name table)))) + (unless arguments + (error "Could not find lisp implementation with the name '%S'" name)) + (when (and (= (length arguments) 1) + (functionp (cl-first arguments))) + (setf arguments (funcall (cl-first arguments)))) + (cl-destructuring-bind ((prog &rest args) &rest keys) arguments + (cl-list* :name name :program prog :program-args args keys)))) + +(defun sly-inferior-lisp-buffer (sly-process-or-connection &optional pop-to-buffer) + "Return PROCESS's buffer. With POP-TO-BUFFER, pop to it." + (interactive (list (sly-process) t)) + (let ((buffer (cond ((and sly-process-or-connection + (process-get sly-process-or-connection + 'sly-inferior-lisp-process)) + (process-buffer sly-process-or-connection)) + (sly-process-or-connection + ;; call ourselves recursively with a + ;; sly-started process + ;; + (sly-inferior-lisp-buffer (sly-process sly-process-or-connection) + pop-to-buffer ))))) + (cond ((and buffer + pop-to-buffer) + (pop-to-buffer buffer)) + ((and pop-to-buffer + sly-process-or-connection) + (sly-message "No *inferior lisp* process for current connection!")) + (pop-to-buffer + (sly-error "No *inferior lisp* buffer"))) + buffer)) + +(defun sly--guess-inferior-lisp-program (&optional interactive) + "Compute pathname to a seemingly valid lisp implementation. +If ERRORP, error if such a thing cannot be found" + (let ((inferior-lisp-program-and-args + (and inferior-lisp-program + (if (listp inferior-lisp-program) + inferior-lisp-program + (split-string-and-unquote inferior-lisp-program))))) + (if (and inferior-lisp-program-and-args + (executable-find (car inferior-lisp-program-and-args))) + (combine-and-quote-strings inferior-lisp-program-and-args) + (let ((guessed (cl-some #'executable-find + '("lisp" "sbcl" "clisp" "cmucl" + "acl" "alisp")))) + (cond ((and guessed + (or (not interactive) + noninteractive + (sly-y-or-n-p + "Can't find `inferior-lisp-program' (set to `%s'). Use `%s' instead? " + inferior-lisp-program guessed))) + guessed) + (interactive + (sly-error + (substitute-command-keys + "Can't find a suitable Lisp. Use \\[sly-info] to read about `Multiple Lisps'"))) + (t + nil)))))) + +(cl-defun sly-start (&key (program + (sly-error "must supply :program")) + program-args + directory + (coding-system sly-net-coding-system) + (init sly-init-function) + name + (buffer (format "*sly-started inferior-lisp for %s*" + (file-name-nondirectory program))) + init-function + env) + "Start a Lisp process and connect to it. +This function is intended for programmatic use if `sly' is not +flexible enough. + +PROGRAM and PROGRAM-ARGS are the filename and argument strings + for the subprocess. +INIT is a function that should return a string to load and start + Slynk. The function will be called with the PORT-FILENAME and ENCODING as + arguments. INIT defaults to `sly-init-function'. +CODING-SYSTEM a symbol for the coding system. The default is + sly-net-coding-system +ENV environment variables for the subprocess (see `process-environment'). +INIT-FUNCTION function to call right after the connection is established. +BUFFER the name of the buffer to use for the subprocess. +NAME a symbol to describe the Lisp implementation +DIRECTORY change to this directory before starting the process. +" + (let ((args (list :program program :program-args program-args :buffer buffer + :coding-system coding-system :init init :name name + :init-function init-function :env env))) + (sly-check-coding-system coding-system) + (let ((proc (sly-maybe-start-lisp program program-args env + directory buffer))) + (sly-inferior-connect proc args) + (sly-inferior-lisp-buffer proc)))) + +;;;###autoload +(defun sly-connect (host port &optional _coding-system interactive-p) + "Connect to a running Slynk server. Return the connection. +With prefix arg, asks if all connections should be closed +before." + (interactive (list (read-from-minibuffer + "[sly] Host: " (cl-first sly-connect-host-history) + nil nil '(sly-connect-host-history . 1)) + (string-to-number + (read-from-minibuffer + "[sly] Port: " (cl-first sly-connect-port-history) + nil nil '(sly-connect-port-history . 1))) + nil t)) + (when (and interactive-p + sly-net-processes + current-prefix-arg + (sly-y-or-n-p "[sly] Close all connections first? ")) + (sly-disconnect-all)) + (sly-message "Connecting to Slynk on port %S.." port) + (let* ((process (sly-net-connect host port)) + (sly-dispatching-connection process)) + (sly-setup-connection process))) + +;;;;; Start inferior lisp +;;; +;;; Here is the protocol for starting SLY via `M-x sly': +;;; +;;; 1. Emacs starts an inferior Lisp process. +;;; 2. Emacs tells Lisp (via stdio) to load and start Slynk. +;;; 3. Lisp recompiles the Slynk if needed. +;;; 4. Lisp starts the Slynk server and writes its TCP port to a temp file. +;;; 5. Emacs reads the temp file to get the port and then connects. +;;; 6. Emacs prints a message of warm encouragement for the hacking ahead. +;;; +;;; Between steps 2-5 Emacs polls for the creation of the temp file so +;;; that it can make the connection. This polling may continue for a +;;; fair while if Slynk needs recompilation. + +(defvar sly-connect-retry-timer nil + "Timer object while waiting for an inferior-lisp to start.") + +(defun sly-abort-connection () + "Abort connection the current connection attempt." + (interactive) + (cond (sly-connect-retry-timer + (sly-cancel-connect-retry-timer) + (sly-message "Cancelled connection attempt.")) + (t (error "Not connecting")))) + +;;; Starting the inferior Lisp and loading Slynk: + +(defun sly-maybe-start-lisp (program program-args env directory buffer) + "Return a new or existing inferior lisp process." + (cond ((not (comint-check-proc buffer)) + (sly-start-lisp program program-args env directory buffer)) + (t (sly-start-lisp program program-args env directory + (generate-new-buffer-name buffer))))) + +(defvar sly-inferior-process-start-hook nil + "Hook called whenever a new process gets started.") + +(defun sly-start-lisp (program program-args env directory buffer) + "Does the same as `inferior-lisp' but less ugly. +Return the created process." + (with-current-buffer (get-buffer-create buffer) + (when directory + (cd (expand-file-name directory))) + (comint-mode) + (let ((process-environment (append env process-environment)) + (process-connection-type nil)) + (comint-exec (current-buffer) "inferior-lisp" program nil program-args)) + (lisp-mode-variables t) + (let ((proc (get-buffer-process (current-buffer)))) + (process-put proc 'sly-inferior-lisp-process t) + (set-process-query-on-exit-flag proc (not sly-kill-without-query-p)) + (run-hooks 'sly-inferior-process-start-hook) + proc))) + +(defun sly-inferior-connect (process args) + "Start a Slynk server in the inferior Lisp and connect." + (sly-delete-slynk-port-file 'quiet) + (sly-start-slynk-server process args) + (sly-read-port-and-connect process)) + +(defun sly-start-slynk-server (inf-process args) + "Start a Slynk server on the inferior lisp." + (cl-destructuring-bind (&key coding-system init &allow-other-keys) args + (with-current-buffer (process-buffer inf-process) + (process-put inf-process 'sly-inferior-lisp-args args) + (let ((str (funcall init (sly-slynk-port-file) coding-system))) + (goto-char (process-mark inf-process)) + (insert-before-markers str) + (process-send-string inf-process str))))) + +(defun sly-inferior-lisp-args (inf-process) + "Return the initial process arguments. +See `sly-start'." + (process-get inf-process 'sly-inferior-lisp-args)) + +(defun sly-init-using-asdf (port-filename coding-system) + "Return a string to initialize Lisp using ASDF. +Fall back to `sly-init-using-slynk-loader' if ASDF fails." + (format "%S\n\n" + `(cond ((ignore-errors + (funcall 'require "asdf") + (funcall (read-from-string "asdf:version-satisfies") + (funcall (read-from-string "asdf:asdf-version")) + "2.019")) + (push (pathname ,(sly-to-lisp-filename (sly-slynk-path))) + (symbol-value + (read-from-string "asdf:*central-registry*"))) + (funcall + (read-from-string "asdf:load-system") + :slynk) + (funcall + (read-from-string "slynk:start-server") + ,(sly-to-lisp-filename port-filename))) + (t + ,(read (sly-init-using-slynk-loader port-filename + coding-system)))))) + +;; XXX load-server & start-server used to be separated. maybe that was better. +(defun sly-init-using-slynk-loader (port-filename _coding-system) + "Return a string to initialize Lisp." + (let ((loader (sly-to-lisp-filename + (expand-file-name sly-slynk-loader-backend (sly-slynk-path))))) + ;; Return a single form to avoid problems with buffered input. + (format "%S\n\n" + `(progn + (load ,loader :verbose t) + (funcall (read-from-string "slynk-loader:init")) + (funcall (read-from-string "slynk:start-server") + ,port-filename))))) + +(defun sly-slynk-port-file () + "Filename where the SLYNK server writes its TCP port number." + (expand-file-name (format "sly.%S" (emacs-pid)) (sly-temp-directory))) + +(defun sly-temp-directory () + (cond ((fboundp 'temp-directory) (temp-directory)) + ((boundp 'temporary-file-directory) temporary-file-directory) + (t "/tmp/"))) + +(defun sly-delete-slynk-port-file (&optional quiet) + (condition-case data + (delete-file (sly-slynk-port-file)) + (error + (cl-ecase quiet + ((nil) (signal (car data) (cdr data))) + (quiet) + (sly-message (sly-message "Unable to delete slynk port file %S" + (sly-slynk-port-file))))))) + +(defun sly-read-port-and-connect (inferior-process) + (sly-attempt-connection inferior-process nil 1)) + +(defcustom sly-connection-poll-interval 0.3 + "Seconds to wait between connection attempts when first connecting." + :type 'number + :group 'sly-ui) + +(defun sly-attempt-connection (process retries attempt) + ;; A small one-state machine to attempt a connection with + ;; timer-based retries. + (sly-cancel-connect-retry-timer) + (let ((file (sly-slynk-port-file))) + (unless (active-minibuffer-window) + (sly-message "Polling %S .. %d (Abort with `M-x sly-abort-connection'.)" + file attempt)) + (cond ((and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) ; file size + (let ((port (sly-read-slynk-port)) + (args (sly-inferior-lisp-args process))) + (sly-delete-slynk-port-file 'message) + (let ((c (sly-connect sly-lisp-host port + (plist-get args :coding-system)))) + (sly-set-inferior-process c process)))) + ((and retries (zerop retries)) + (sly-message "Gave up connecting to Slynk after %d attempts." attempt)) + ((eq (process-status process) 'exit) + (sly-message "Failed to connect to Slynk: inferior process exited.")) + (t + (when (and (file-exists-p file) + (zerop (nth 7 (file-attributes file)))) + (sly-message "(Zero length port file)") + ;; the file may be in the filesystem but not yet written + (unless retries (setq retries 3))) + (cl-assert (not sly-connect-retry-timer)) + (setq sly-connect-retry-timer + (run-with-timer + sly-connection-poll-interval nil + (lambda () + (let ((sly-ignore-protocol-mismatches + sly-ignore-protocol-mismatches)) + (sly-attempt-connection process (and retries (1- retries)) + (1+ attempt)))))))))) + +(defun sly-cancel-connect-retry-timer () + (when sly-connect-retry-timer + (cancel-timer sly-connect-retry-timer) + (setq sly-connect-retry-timer nil))) + +(defun sly-read-slynk-port () + "Read the Slynk server port number from the `sly-slynk-port-file'." + (save-excursion + (with-temp-buffer + (insert-file-contents (sly-slynk-port-file)) + (goto-char (point-min)) + (let ((port (read (current-buffer)))) + (cl-assert (integerp port)) + port)))) + +(defun sly-toggle-debug-on-slynk-error () + (interactive) + (if (sly-eval `(slynk:toggle-debug-on-slynk-error)) + (sly-message "Debug on SLYNK error enabled.") + (sly-message "Debug on SLYNK error disabled."))) + +;;; Words of encouragement + +(defun sly-user-first-name () + (let ((name (if (string= (user-full-name) "") + (user-login-name) + (user-full-name)))) + (string-match "^[^ ]*" name) + (capitalize (match-string 0 name)))) + +(defvar sly-words-of-encouragement + `("Let the hacking commence!" + "Hacks and glory await!" + "Hack and be merry!" + "Your hacking starts... NOW!" + "May the source be with you!" + "Take this REPL, brother, and may it serve you well." + "Lemonodor-fame is but a hack away!" + "Are we consing yet?" + ,(format "%s, this could be the start of a beautiful program." + (sly-user-first-name))) + "Scientifically-proven optimal words of hackerish encouragement.") + +(defun sly-random-words-of-encouragement () + "Return a string of hackerish encouragement." + (eval (nth (random (length sly-words-of-encouragement)) + sly-words-of-encouragement) + t)) + + +;;;; Networking +;;; +;;; This section covers the low-level networking: establishing +;;; connections and encoding/decoding protocol messages. +;;; +;;; Each SLY protocol message beings with a 6-byte header followed +;;; by an S-expression as text. The sexp must be readable both by +;;; Emacs and by Common Lisp, so if it contains any embedded code +;;; fragments they should be sent as strings: +;;; +;;; The set of meaningful protocol messages are not specified +;;; here. They are defined elsewhere by the event-dispatching +;;; functions in this file and in slynk.lisp. + +(defvar sly-net-processes nil + "List of processes (sockets) connected to Lisps.") + +(defvar sly-net-process-close-hooks '() + "List of functions called when a sly network connection closes. +The functions are called with the process as their argument.") + +(defun sly-secret () + "Find the magic secret from the user's home directory. +Return nil if the file doesn't exist or is empty; otherwise the +first line of the file." + (condition-case _err + (with-temp-buffer + (insert-file-contents "~/.sly-secret") + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position))) + (file-error nil))) + +;;; Interface +(defvar sly--net-connect-counter 0) + +(defun sly-send-secret (proc) + (sly--when-let (secret (sly-secret)) + (let* ((payload (encode-coding-string secret 'utf-8-unix)) + (string (concat (sly-net-encode-length (length payload)) + payload))) + (process-send-string proc string)))) + +(defun sly-net-connect (host port) + "Establish a connection with a CL." + (let* ((inhibit-quit nil) + (name (format "sly-%s" (cl-incf sly--net-connect-counter))) + (connection (open-network-stream name nil host port)) + (buffer (sly-make-net-buffer (format " *%s*" name)))) + (push connection sly-net-processes) + (set-process-plist connection `(sly--net-connect-counter + ,sly--net-connect-counter)) + (set-process-buffer connection buffer) + (set-process-filter connection 'sly-net-filter) + (set-process-sentinel connection 'sly-net-sentinel) + (set-process-query-on-exit-flag connection (not sly-kill-without-query-p)) + (when (fboundp 'set-process-coding-system) + (set-process-coding-system connection 'binary 'binary)) + (sly-send-secret connection) + connection)) + +(defun sly-make-net-buffer (name) + "Make a buffer suitable for a network process." + (let ((buffer (generate-new-buffer name))) + (with-current-buffer buffer + (buffer-disable-undo) + (set (make-local-variable 'kill-buffer-query-functions) nil)) + buffer)) + +;;;;; Coding system madness + +(defun sly-check-coding-system (coding-system) + "Signal an error if CODING-SYSTEM isn't a valid coding system." + (interactive) + (let ((props (sly-find-coding-system coding-system))) + (unless props + (error "Invalid sly-net-coding-system: %s. %s" + coding-system (mapcar #'car sly-net-valid-coding-systems))) + (when (and (cl-second props) (boundp 'default-enable-multibyte-characters)) + (cl-assert default-enable-multibyte-characters)) + t)) + +(defun sly-coding-system-mulibyte-p (coding-system) + (cl-second (sly-find-coding-system coding-system))) + +(defun sly-coding-system-cl-name (coding-system) + (cl-third (sly-find-coding-system coding-system))) + +;;; Interface +(defvar sly-net-send-translator nil + "If non-nil, function to translate outgoing sexps for the wire.") + +(defun sly--sanitize-or-lose (form) + "Sanitize FORM for Slynk or error." + (cl-typecase form + (number) + (symbol 'fonix) + (string (set-text-properties 0 (length form) nil form)) + (cons (sly--sanitize-or-lose (car form)) + (sly--sanitize-or-lose (cdr form))) + (t (sly-error "Can't serialize %s for Slynk." form))) + form) + +(defun sly-net-send (sexp proc) + "Send a SEXP to Lisp over the socket PROC. +This is the lowest level of communication. The sexp will be READ and +EVAL'd by Lisp." + (let* ((print-circle nil) + (print-quoted nil) + (sexp (sly--sanitize-or-lose sexp)) + (sexp (if (and sly-net-send-translator + (fboundp sly-net-send-translator)) + (funcall sly-net-send-translator sexp) + sexp)) + (payload (encode-coding-string + (concat (sly-prin1-to-string sexp) "\n") + 'utf-8-unix)) + (string (concat (sly-net-encode-length (length payload)) + payload))) + (sly-log-event sexp proc) + (process-send-string proc string))) + +(defun sly-safe-encoding-p (coding-system string) + "Return true iff CODING-SYSTEM can safely encode STRING." + (or (let ((candidates (find-coding-systems-string string)) + (base (coding-system-base coding-system))) + (or (equal candidates '(undecided)) + (memq base candidates))) + (and (not (multibyte-string-p string)) + (not (sly-coding-system-mulibyte-p coding-system))))) + +(defun sly-net-close (connection reason &optional debug _force) + "Close the network connection CONNECTION because REASON." + (process-put connection 'sly-net-close-reason reason) + (setq sly-net-processes (remove connection sly-net-processes)) + (when (eq connection sly-default-connection) + (setq sly-default-connection nil)) + ;; Run hooks + ;; + (unless debug + (run-hook-with-args 'sly-net-process-close-hooks connection)) + ;; We close the socket connection by killing its hidden + ;; *sly-* buffer, but we first unset the connection's + ;; sentinel otherwise we could get a second `sly-net-close' call. In + ;; case the buffer is already killed (we killed it manually), this + ;; function is probably running as a result of that, and rekilling + ;; it is harmless. + ;; + (set-process-sentinel connection nil) + (when debug + (set-process-filter connection nil)) + (if debug + (delete-process connection) ; leave the buffer + (kill-buffer (process-buffer connection)))) + +(defun sly-net-sentinel (process message) + (let ((reason (format "Lisp connection closed unexpectedly: %s" message))) + (sly-message reason) + (sly-net-close process reason))) + +;;; Socket input is handled by `sly-net-filter', which decodes any +;;; complete messages and hands them off to the event dispatcher. + +(defun sly-net-filter (process string) + "Accept output from the socket and process all complete messages." + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string)) + (sly-process-available-input process)) + +(defun sly-process-available-input (process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (sly-net-have-input-p) + (let ((event (sly-net-read-or-lose process)) + (ok nil)) + (sly-log-event event process) + (unwind-protect + (save-current-buffer + (sly-dispatch-event event process) + (setq ok t)) + (unless ok + (run-at-time 0 nil 'sly-process-available-input process))))))) + +(defsubst sly-net-decode-length () + (string-to-number (buffer-substring (point) (+ (point) 6)) + 16)) + +(defun sly-net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (sly-net-decode-length)))) + +(defun sly-handle-net-read-error (error) + (let ((packet (buffer-string))) + (sly-with-popup-buffer ((sly-buffer-name :error + :connection (get-buffer-process (current-buffer)))) + (princ (format "%s\nin packet:\n%s" (error-message-string error) packet)) + (goto-char (point-min))) + (cond ((sly-y-or-n-p "Skip this packet? ") + `(:emacs-skipped-packet ,packet)) + (t + (when (sly-y-or-n-p "Enter debugger instead? ") + (debug 'error error)) + (signal (car error) (cdr error)))))) + +(defun sly-net-read-or-lose (process) + (condition-case error + (sly-net-read) + (error + (sly-net-close process "Fatal net-read error" t) + (error "net-read error: %S" error)))) + +(defun sly-net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (sly-net-decode-length)) + (start (+ (point) 6)) + (end (+ start length))) + (cl-assert (cl-plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (condition-case error + (progn + (decode-coding-region start end 'utf-8-unix) + (setq end (point-max)) + (read (current-buffer))) + (error + (sly-handle-net-read-error error)))) + (delete-region (point-min) end)))) + +(defun sly-net-encode-length (n) + (format "%06x" n)) + +(defun sly-prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1-to-string sexp))) + + +;;;; Connections +;;; +;;; "Connections" are the high-level Emacs<->Lisp networking concept. +;;; +;;; Emacs has a connection to each Lisp process that it's interacting +;;; with. Typically there would only be one, but a user can choose to +;;; connect to many Lisps simultaneously. +;;; +;;; A connection consists of a control socket, optionally an extra +;;; socket dedicated to receiving Lisp output (an optimization), and a +;;; set of connection-local state variables. +;;; +;;; The state variables are stored as buffer-local variables in the +;;; control socket's process-buffer and are used via accessor +;;; functions. These variables include things like the *FEATURES* list +;;; and Unix Pid of the Lisp process. +;;; +;;; One connection is "current" at any given time. This is: +;;; `sly-dispatching-connection' if dynamically bound, or +;;; `sly-buffer-connection' if this is set buffer-local, or +;;; `sly-default-connection' otherwise. +;;; +;;; When you're invoking commands in your source files you'll be using +;;; `sly-default-connection'. This connection can be interactively +;;; reassigned via the connection-list buffer. +;;; +;;; When a command creates a new buffer it will set +;;; `sly-buffer-connection' so that commands in the new buffer will +;;; use the connection that the buffer originated from. For example, +;;; the apropos command creates the *Apropos* buffer and any command +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the +;;; apropos search. REPL buffers are similarly tied to their +;;; respective connections. +;;; +;;; When Emacs is dispatching some network message that arrived from a +;;; connection it will dynamically bind `sly-dispatching-connection' +;;; so that the event will be processed in the context of that +;;; connection. +;;; +;;; This is mostly transparent. The user should be aware that he can +;;; set the default connection to pick which Lisp handles commands in +;;; Lisp-mode source buffers, and sly hackers should be aware that +;;; they can tie a buffer to a specific connection. The rest takes +;;; care of itself. + +(defvar sly-dispatching-connection nil + "Network process currently executing. +This is dynamically bound while handling messages from Lisp; it +overrides `sly-buffer-connection' and `sly-default-connection'.") + +(make-variable-buffer-local + (defvar sly-buffer-connection nil + "Network connection to use in the current buffer. +This overrides `sly-default-connection'.")) + +(defvar sly-default-connection nil + "Network connection to use by default. +Used for all Lisp communication, except when overridden by +`sly-dispatching-connection' or `sly-buffer-connection'.") + +(defun sly-current-connection () + "Return the connection to use for Lisp interaction. +Return nil if there's no connection." + (or sly-dispatching-connection + sly-buffer-connection + sly-default-connection)) + +(defun sly-connection () + "Return the connection to use for Lisp interaction. +Signal an error if there's no connection." + (let ((conn (sly-current-connection))) + (cond ((and (not conn) sly-net-processes) + (or (sly-auto-select-connection) + (error "Connections available, but none selected."))) + ((not conn) + (or (sly-auto-start) + (error "No current SLY connection."))) + ((not (process-live-p conn)) + (error "Current connection %s is closed." conn)) + (t conn)))) + +(define-obsolete-variable-alias 'sly-auto-connect + 'sly-auto-start "2.5") +(defcustom sly-auto-start 'never + "Controls auto connection when information from lisp process is needed. +This doesn't mean it will connect right after SLY is loaded." + :group 'sly-mode + :type '(choice (const never) + (const always) + (const ask))) + +(defun sly-auto-start () + (cond ((or (eq sly-auto-start 'always) + (and (eq sly-auto-start 'ask) + (sly-y-or-n-p "No connection. Start SLY? "))) + (save-window-excursion + (sly) + (while (not (sly-current-connection)) + (sleep-for 1)) + (sly-connection))) + (t nil))) + +(cl-defmacro sly-with-connection-buffer ((&optional process) &rest body) + "Execute BODY in the process-buffer of PROCESS. +If PROCESS is not specified, `sly-connection' is used. + +\(fn (&optional PROCESS) &body BODY))" + (declare (indent 1)) + `(with-current-buffer + (process-buffer (or ,process (sly-connection) + (error "No connection"))) + ,@body)) + +;;; Connection-local variables: + +(defmacro sly-def-connection-var (varname &rest initial-value-and-doc) + "Define a connection-local variable. +The value of the variable can be read by calling the function of the +same name (it must not be accessed directly). The accessor function is +setf-able. + +The actual variable bindings are stored buffer-local in the +process-buffers of connections. The accessor function refers to +the binding for `sly-connection'." + (declare (indent 2)) + `(progn + ;; Accessor + (defun ,varname (&optional process) + ,(cl-second initial-value-and-doc) + (let ((process (or process + (sly-current-connection) + (error "Can't access prop %s for no connection" ',varname)))) + (or (process-get process ',varname) + (let ((once ,(cl-first initial-value-and-doc))) + (process-put process ',varname once) + once)))) + ;; Setf + (gv-define-setter ,varname (store &optional process) + `(let ((process (or ,process + (sly-current-connection) + (error "Can't access prop %s for no connection" ',',varname))) + (store-once ,store)) + (process-put process ',',varname store-once) + store-once)) + '(\, varname))) + +(sly-def-connection-var sly-connection-number nil + "Serial number of a connection. +Bound in the connection's process-buffer.") + +(sly-def-connection-var sly-lisp-features '() + "The symbol-names of Lisp's *FEATURES*. +This is automatically synchronized from Lisp.") + +(sly-def-connection-var sly-lisp-modules '() + "The strings of Lisp's *MODULES*.") + +(sly-def-connection-var sly-pid nil + "The process id of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-type nil + "The implementation type of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-version nil + "The implementation type of the Lisp process.") + +(sly-def-connection-var sly-lisp-implementation-name nil + "The short name for the Lisp implementation.") + +(sly-def-connection-var sly-lisp-implementation-program nil + "The argv[0] of the process running the Lisp implementation.") + +(sly-def-connection-var sly-connection-name nil + "The short name for connection.") + +(sly-def-connection-var sly-inferior-process nil + "The inferior process for the connection if any.") + +(sly-def-connection-var sly-communication-style nil + "The communication style.") + +(sly-def-connection-var sly-machine-instance nil + "The name of the (remote) machine running the Lisp process.") + +(sly-def-connection-var sly-connection-coding-systems nil + "Coding systems supported by the Lisp process.") + +;;;;; Connection setup + +(defvar sly-connection-counter 0 + "The number of SLY connections made. For generating serial numbers.") + +;;; Interface +(defun sly-setup-connection (process) + "Make a connection out of PROCESS." + (let ((sly-dispatching-connection process)) + (sly-init-connection-state process) + (sly-select-connection process) + (sly--setup-contribs) + process)) + +(defun sly-init-connection-state (proc) + "Initialize connection state in the process-buffer of PROC." + ;; To make life simpler for the user: if this is the only open + ;; connection then reset the connection counter. + (when (equal sly-net-processes (list proc)) + (setq sly-connection-counter 0)) + (sly-with-connection-buffer () + (setq sly-buffer-connection proc)) + (setf (sly-connection-number proc) (cl-incf sly-connection-counter)) + ;; We do the rest of our initialization asynchronously. The current + ;; function may be called from a timer, and if we setup the REPL + ;; from a timer then it mysteriously uses the wrong keymap for the + ;; first command. + (let ((sly-current-thread t)) + (sly-eval-async '(slynk:connection-info) + (sly-curry #'sly-set-connection-info proc) + nil + `((sly-ignore-protocol-mismatches . ,sly-ignore-protocol-mismatches))))) + +(defun sly--trampling-rename-buffer (newname) + "Rename current buffer NEWNAME, trampling over existing ones." + (let ((existing (get-buffer newname))) + (unless (eq existing + (current-buffer)) + ;; Trample over any existing buffers on reconnection + (when existing + (let ((kill-buffer-query-functions nil)) + (kill-buffer existing))) + (rename-buffer newname)))) + +(defun sly-set-connection-info (connection info) + "Initialize CONNECTION with INFO received from Lisp." + (let ((sly-dispatching-connection connection) + (sly-current-thread t)) + (cl-destructuring-bind (&key pid style lisp-implementation machine + features version modules encoding + &allow-other-keys) info + (sly-check-version version connection) + (setf (sly-pid) pid + (sly-communication-style) style + (sly-lisp-features) features + (sly-lisp-modules) modules) + (cl-destructuring-bind (&key type name version program) + lisp-implementation + (setf (sly-lisp-implementation-type) type + (sly-lisp-implementation-version) version + (sly-lisp-implementation-name) name + (sly-lisp-implementation-program) program + (sly-connection-name) (sly-generate-connection-name name))) + (cl-destructuring-bind (&key instance ((:type _)) ((:version _))) machine + (setf (sly-machine-instance) instance)) + (cl-destructuring-bind (&key coding-systems) encoding + (setf (sly-connection-coding-systems) coding-systems))) + (let ((args (sly--when-let (p (sly-inferior-process)) + (sly-inferior-lisp-args p)))) + (sly--when-let (name (plist-get args ':name)) + (unless (string= (sly-lisp-implementation-name) name) + (setf (sly-connection-name) + (sly-generate-connection-name (symbol-name name))))) + (sly-contrib--load-slynk-dependencies) + (run-hooks 'sly-connected-hook) + (sly--when-let (fun (plist-get args ':init-function)) + (funcall fun))) + ;; Give the events buffer its final name + (with-current-buffer (sly--events-buffer connection) + (sly--trampling-rename-buffer (sly-buffer-name + :events + :connection connection))) + ;; Rename the inferior lisp buffer if there is one (i.e. when + ;; started via `M-x sly') + ;; + (let ((inferior-lisp-buffer (sly-inferior-lisp-buffer + (sly-process connection)))) + (when inferior-lisp-buffer + (with-current-buffer inferior-lisp-buffer + (sly--trampling-rename-buffer (sly-buffer-name + :inferior-lisp + :connection connection))))) + (sly-message "Connected. %s" (sly-random-words-of-encouragement)))) + +(defun sly-check-version (version conn) + (or (equal version sly-protocol-version) + (null sly-protocol-version) + sly-ignore-protocol-mismatches + (sly-y-or-n-p + (format "Versions differ: %s (sly) vs. %s (slynk). Continue? " + sly-protocol-version version)) + (sly-net-close conn "Versions differ") + (top-level))) + +(defun sly-generate-connection-name (lisp-name) + (when (file-exists-p lisp-name) + (setq lisp-name (file-name-nondirectory lisp-name))) + (cl-loop for i from 1 + for name = lisp-name then (format "%s<%d>" lisp-name i) + while (cl-find name sly-net-processes + :key #'sly-connection-name :test #'equal) + finally (cl-return name))) + +(defun sly-select-new-default-connection (conn) + "If dead CONN was the default connection, select a new one." + (when (eq conn sly-default-connection) + (when sly-net-processes + (sly-select-connection (car sly-net-processes)) + (sly-message "Default connection closed; default is now #%S (%S)" + (sly-connection-number) + (sly-connection-name))))) + +(defcustom sly-keep-buffers-on-connection-close '(:mrepl) + "List of buffers to keep around after a connection closes." + :group 'sly-mode + :type '(repeat + (choice + (const :tag "Debugger" :db) + (const :tag "Repl" :mrepl) + (const :tag "Ispector" :inspector) + (const :tag "Stickers replay" :stickers-replay) + (const :tag "Error" :error) + (const :tag "Source" :source) + (const :tag "Compilation" :compilation) + (const :tag "Apropos" :apropos) + (const :tag "Xref" :xref) + (const :tag "Macroexpansion" :macroexpansion) + (symbol :tag "Other")))) + +(defun sly-kill-stale-connection-buffers (conn) ; + "If CONN had some stale buffers, kill them. +Respect `sly-keep-buffers-on-connection-close'." + (let ((buffer-list (buffer-list)) + (matchers + (mapcar + (lambda (type) + (format ".*%s.*$" + ;; XXX: this is synched with `sly-buffer-name'. + (regexp-quote (format "*sly-%s" + (downcase (substring (symbol-name type) + 1)))))) + (cl-set-difference '(:db + :mrepl + :inspector + :stickers-replay + :error + :source + :compilation + :apropos + :xref + :macroexpansion) + sly-keep-buffers-on-connection-close)))) + (cl-loop for buffer in buffer-list + when (and (cl-some (lambda (matcher) + (string-match matcher (buffer-name buffer))) + matchers) + (with-current-buffer buffer + (eq sly-buffer-connection conn))) + do (kill-buffer buffer)))) + +(add-hook 'sly-net-process-close-hooks 'sly-select-new-default-connection) +(add-hook 'sly-net-process-close-hooks 'sly-kill-stale-connection-buffers 'append) + +;;;;; Commands on connections + +(defun sly--purge-connections () + "Purge `sly-net-processes' of dead processes, return living." + (cl-loop for process in sly-net-processes + if (process-live-p process) + collect process + else do + (sly-warning "process %s in `sly-net-processes' dead. Force closing..." process) + (sly-net-close process "process state invalid" nil t))) + +(defun sly-prompt-for-connection (&optional prompt connections dont-require-match) + (let* ((connections (or connections (sly--purge-connections))) + (connection-names (cl-loop for process in + (sort connections + #'(lambda (p1 _p2) + (eq p1 (sly-current-connection)))) + collect (sly-connection-name process))) + (connection-names (if dont-require-match + (cons dont-require-match + connection-names) + connection-names)) + (connection-name (and connection-names + (completing-read + (or prompt "Connection: ") + connection-names + nil (not dont-require-match)))) + (target (cl-find connection-name sly-net-processes :key #'sly-connection-name + :test #'string=))) + (cond (target target) + ((and dont-require-match (or (zerop (length connection-name)) + (string= connection-name dont-require-match))) + nil) + (connection-name + (sly-error "No such connection")) + (t + (sly-error "No connections"))))) + +(defun sly-auto-select-connection () + (let* ((c0 (car (sly--purge-connections))) + (c (cond ((eq sly-auto-select-connection 'always) c0) + ((and (eq sly-auto-select-connection 'ask) + (sly-prompt-for-connection "Choose a new default connection: ")))))) + (when c + (sly-select-connection c) + (sly-message "Switching to connection: %s" (sly-connection-name c)) + c))) + +(defvar sly-select-connection-hook nil) + +(defun sly-select-connection (process) + "Make PROCESS the default connection." + (setq sly-default-connection process) + (run-hooks 'sly-select-connection-hook)) + +(define-obsolete-function-alias 'sly-cycle-connections 'sly-next-connection "1.0.0-beta") + +(defun sly-next-connection (arg &optional dont-wrap) + "Switch to the next SLY connection, cycling through all connections. +Skip ARG-1 connections. Negative ARG means cycle back. DONT-WRAP +means don't wrap around when last connection is reached." + (interactive "p") + (cl-labels ((connection-full-name + (c) + (format "%s %s" (sly-connection-name c) (process-contact c)))) + (cond ((not sly-net-processes) + (sly-error "No connections to cycle")) + ((null (cdr sly-net-processes)) + (sly-message "Only one connection: %s" (connection-full-name (car sly-net-processes)))) + (t + (let* ((dest (append (member (sly-current-connection) + sly-net-processes) + (unless dont-wrap sly-net-processes))) + (len (length sly-net-processes)) + (target (nth (mod arg len) + dest))) + (unless target + (sly-error "No more connections")) + (sly-select-connection target) + (if (and sly-buffer-connection + (not (eq sly-buffer-connection target))) + (sly-message "switched to: %s but buffer remains in: %s" + (connection-full-name target) + (connection-full-name sly-buffer-connection)) + (sly-message "switched to: %s (%s/%s)" (connection-full-name target) + (1+ (cl-position target sly-net-processes)) + len)) + (sly--refresh-mode-line)))))) + +(defun sly-prev-connection (arg &optional dont-wrap) + "Switch to the previous SLY connection, cycling through all connections. +See `sly-next-connection' for other args." + (interactive "p") + (sly-next-connection (- arg) dont-wrap)) + +(defun sly-disconnect (&optional interactive) + "Close the current connection." + (interactive (list t)) + (let ((connection (if interactive + (sly-prompt-for-connection "Connection to disconnect: ") + (sly-current-connection)))) + (sly-net-close connection "Disconnecting"))) + +(defun sly-disconnect-all () + "Disconnect all connections." + (interactive) + (mapc #'(lambda (process) + (sly-net-close process "Disconnecting all connections")) + sly-net-processes)) + +(defun sly-connection-port (connection) + "Return the remote port number of CONNECTION." + (cadr (process-contact connection))) + +(defun sly-process (&optional connection) + "Return the Lisp process for CONNECTION (default `sly-connection'). +Return nil if there's no process object for the connection." + (let ((proc (sly-inferior-process connection))) + (if (and proc + (memq (process-status proc) '(run stop))) + proc))) + +;; Non-macro version to keep the file byte-compilable. +(defun sly-set-inferior-process (connection process) + (setf (sly-inferior-process connection) process)) + +(defun sly-use-sigint-for-interrupt (&optional connection) + (let ((c (or connection (sly-connection)))) + (cl-ecase (sly-communication-style c) + ((:fd-handler nil) t) + ((:spawn :sigio) nil)))) + +(defvar sly-inhibit-pipelining t + "*If true, don't send background requests if Lisp is already busy.") + +(defun sly-background-activities-enabled-p () + (and (let ((con (sly-current-connection))) + (and con + (eq (process-status con) 'open))) + (or (not (sly-busy-p)) + (not sly-inhibit-pipelining)))) + + +;;;; Communication protocol + +;;;;; Emacs Lisp programming interface +;;; +;;; The programming interface for writing Emacs commands is based on +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp +;;; to apply a named Lisp function to some arguments, then to do +;;; something with the result. +;;; +;;; Requests can be either synchronous (blocking) or asynchronous +;;; (with the result passed to a callback/continuation function). If +;;; an error occurs during the request then the debugger is entered +;;; before the result arrives -- for synchronous evaluations this +;;; requires a recursive edit. +;;; +;;; You should use asynchronous evaluations (`sly-eval-async') for +;;; most things. Reserve synchronous evaluations (`sly-eval') for +;;; the cases where blocking Emacs is really appropriate (like +;;; completion) and that shouldn't trigger errors (e.g. not evaluate +;;; user-entered code). +;;; +;;; We have the concept of the "current Lisp package". RPC requests +;;; always say what package the user is making them from and the Lisp +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees +;;; fit. The current package is defined as the buffer-local value of +;;; `sly-buffer-package' if set, and otherwise the package named by +;;; the nearest IN-PACKAGE as found by text search (cl-first backwards, +;;; then forwards). +;;; +;;; Similarly we have the concept of the current thread, i.e. which +;;; thread in the Lisp process should handle the request. The current +;;; thread is determined solely by the buffer-local value of +;;; `sly-current-thread'. This is usually bound to t meaning "no +;;; particular thread", but can also be used to nominate a specific +;;; thread. The REPL and the debugger both use this feature to deal +;;; with specific threads. + +(make-variable-buffer-local + (defvar sly-current-thread t + "The id of the current thread on the Lisp side. +t means the \"current\" thread; +fixnum a specific thread.")) + +(make-variable-buffer-local + (defvar sly-buffer-package nil + "The Lisp package associated with the current buffer. +This is set only in buffers bound to specific packages.")) + +;;; `sly-rex' is the RPC primitive which is used to implement both +;;; `sly-eval' and `sly-eval-async'. You can use it directly if +;;; you need to, but the others are usually more convenient. + +(defvar sly-rex-extra-options-functions nil + "Functions returning extra options to send with `sly-rex'.") + +(cl-defmacro sly-rex ((&rest _) + (sexp &optional + (package '(sly-current-package)) + (thread 'sly-current-thread)) + &rest continuations) + "(sly-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...) + +Remote EXecute SEXP. + +SEXP is evaluated and the princed version is sent to Lisp. + +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package. +The default value is (sly-current-package). + +CLAUSES is a list of patterns with same syntax as +`sly-dcase'. The result of the evaluation of SEXP is +dispatched on CLAUSES. The result is either a sexp of the +form (:ok VALUE) or (:abort CONDITION). CLAUSES is executed +asynchronously. + +Note: don't use backquote syntax for SEXP, because various Emacs +versions cannot deal with that." + (declare (indent 2) + (debug (sexp (form &optional sexp sexp) + &rest (sexp &rest form)))) + (let ((result (cl-gensym))) + `(sly-dispatch-event + (cl-list* :emacs-rex ,sexp ,package ,thread + (lambda (,result) + (sly-dcase ,result + ,@continuations)) + (cl-loop for fn in sly-rex-extra-options-functions + append (funcall fn)))))) + +;;; Interface +(defun sly-current-package () + "Return the Common Lisp package in the current context. +If `sly-buffer-package' has a value then return that, otherwise +search for and read an `in-package' form." + (or sly-buffer-package + (save-restriction + (widen) + (sly-find-buffer-package)))) + +(defvar sly-find-buffer-package-function 'sly-search-buffer-package + "*Function to use for `sly-find-buffer-package'. +The result should be the package-name (a string) +or nil if nothing suitable can be found.") + +(defun sly-find-buffer-package () + "Figure out which Lisp package the current buffer is associated with." + (funcall sly-find-buffer-package-function)) + +(make-variable-buffer-local + (defvar sly-package-cache nil + "Cons of the form (buffer-modified-tick . package)")) + +;; When modifing this code consider cases like: +;; (in-package #.*foo*) +;; (in-package #:cl) +;; (in-package :cl) +;; (in-package "CL") +;; (in-package |CL|) +;; (in-package #+ansi-cl :cl #-ansi-cl 'lisp) + +(defun sly-search-buffer-package () + (let ((case-fold-search t) + (regexp (concat "^[ \t]*(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*" + "\\([^)]+\\)[ \t]*)"))) + (save-excursion + (when (or (re-search-backward regexp nil t) + (re-search-forward regexp nil t)) + (match-string-no-properties 2))))) + +;;; Synchronous requests are implemented in terms of asynchronous +;;; ones. We make an asynchronous request with a continuation function +;;; that `throw's its result up to a `catch' and then enter a loop of +;;; handling I/O until that happens. + +(defvar sly--stack-eval-tags nil + "List of stack-tags of waiting on the elisp stack. +This is used by the sly-db debugger to decide whether to enter a +`recursive-edit', so that if a synchronous `sly-eval' request +errors and brings us a Slynk debugger, we can fix the error, +invoke a restart and still get the return value of the `sly-eval' +as if nothing had happened.") + +(defun sly-eval (sexp &optional package cancel-on-input cancel-on-input-retval) + "Evaluate SEXP in Slynk's PACKAGE and return the result. +If CANCEL-ON-INPUT cancel the request immediately if the user +wants to input, and return CANCEL-ON-INPUT-RETVAL." + (when (null package) (setq package (sly-current-package))) + (let* ((catch-tag (make-symbol (format "sly-result-%d" + (sly-continuation-counter)))) + (sly--stack-eval-tags (cons catch-tag sly--stack-eval-tags)) + (cancelled nil) + (check-conn + (lambda () + (unless (eq (process-status (sly-connection)) 'open) + (error "Lisp connection closed unexpectedly")))) + (retval + (unwind-protect + (catch catch-tag + (sly-rex () + (sexp package) + ((:ok value) + (unless cancelled + (unless (member catch-tag sly--stack-eval-tags) + (error "Reply to nested `sly-eval' request with tag=%S sexp=%S" + catch-tag sexp)) + (throw catch-tag (list #'identity value)))) + ((:abort _condition) + (unless cancelled + (throw catch-tag + (list #'error "Synchronous Lisp Evaluation aborted"))))) + (cond (cancel-on-input + ;; Setting `inhibit-quit' to t helps with + ;; callers that wrap us in `while-no-input', + ;; like `fido-mode' and Helm. It doesn't seem + ;; to create any specific problems, since + ;; `sit-for' exits immediately given input + ;; anyway. This include the C-g input, and + ;; thus even with `inhibit-quit' set to t, quit + ;; happens immediately. + (unwind-protect + (let ((inhibit-quit t)) (while (sit-for 30))) + (setq cancelled t)) + (funcall check-conn)) + (t + (while t + (funcall check-conn) + (accept-process-output nil 30)))) + (list #'identity cancel-on-input-retval)) + ;; Protect against user quit during + ;; `accept-process-output' or `sit-for', so that if the + ;; Lisp is alive and replies, we don't get an error. + (setq cancelled t)))) + (apply (car retval) (cdr retval)))) + +(defun sly-eval-async (sexp &optional cont package env) + "Evaluate SEXP on the superior Lisp and call CONT with the result. + +CONT is called with the overriding dynamic environment in ENV, an +alist of bindings" + (declare (indent 1)) + (let ((buffer (current-buffer))) + (sly-rex () + (sexp (or package (sly-current-package))) + ((:ok result) + (when cont + (set-buffer buffer) + (cl-progv (mapcar #'car env) (mapcar #'cdr env) + (if debug-on-error + (funcall cont result) + (condition-case err + (funcall cont result) + (error + (sly-message "`sly-eval-async' errored: %s" + (if (and (eq 'error (car err)) + (stringp (cadr err))) + (cadr err) + err)))))))) + ((:abort condition) + (sly-message "Evaluation aborted on %s." condition)))) + ;; Guard against arbitrary return values which once upon a time + ;; showed up in the minibuffer spuriously (due to a bug in + ;; sly-autodoc.) If this ever happens again, returning the + ;; following will make debugging much easier: + :sly-eval-async) + +;;; These functions can be handy too: + +(defun sly-connected-p () + "Return true if the Slynk connection is open." + (not (null sly-net-processes))) + +(defun sly-check-connected () + "Signal an error if we are not connected to Lisp." + (unless (sly-connected-p) + (error "Not connected. Use `%s' to start a Lisp." + (substitute-command-keys "\\[sly]")))) + +;; UNUSED +(defun sly-debugged-connection-p (conn) + ;; This previously was (AND (SLY-DB-DEBUGGED-CONTINUATIONS CONN) T), + ;; but an SLY-DB buffer may exist without having continuations + ;; attached to it, e.g. the one resulting from `sly-interrupt'. + (cl-loop for b in (sly-db-buffers) + thereis (with-current-buffer b + (eq sly-buffer-connection conn)))) + +(defun sly-busy-p (&optional conn) + "True if Lisp has outstanding requests. +Debugged requests are ignored." + (let ((debugged (sly-db-debugged-continuations (or conn (sly-connection))))) + (cl-remove-if (lambda (id) + (memq id debugged)) + (sly-rex-continuations) + :key #'car))) + +(defun sly-sync () + "Block until the most recent request has finished." + (when (sly-rex-continuations) + (let ((tag (caar (sly-rex-continuations)))) + (while (cl-find tag (sly-rex-continuations) :key #'car) + (accept-process-output nil 0.1))))) + +(defun sly-ping () + "Check that communication works." + (interactive) + (sly-message "%s" (sly-eval "PONG"))) + +;;;;; Protocol event handler (the guts) +;;; +;;; This is the protocol in all its glory. The input to this function +;;; is a protocol event that either originates within Emacs or arrived +;;; over the network from Lisp. +;;; +;;; Each event is a list beginning with a keyword and followed by +;;; arguments. The keyword identifies the type of event. Events +;;; originating from Emacs have names starting with :emacs- and events +;;; from Lisp don't. + +(sly-def-connection-var sly-rex-continuations '() + "List of (ID . FUNCTION) continuations waiting for RPC results.") + +(sly-def-connection-var sly-continuation-counter 0 + "Continuation serial number counter.") + +(defvar sly-event-hooks) + +(defun sly-dispatch-event (event &optional process) + (let ((sly-dispatching-connection (or process (sly-connection)))) + (or (run-hook-with-args-until-success 'sly-event-hooks event) + (sly-dcase event + ((:emacs-rex form package thread continuation &rest extra-options) + (when (and (sly-use-sigint-for-interrupt) (sly-busy-p)) + (sly-display-oneliner "; pipelined request... %S" form)) + (let ((id (cl-incf (sly-continuation-counter)))) + ;; JT@2020-12-10: FIXME: Force inhibit-quit here to + ;; ensure atomicity between `sly-send' and the `push'? + ;; See Github#385.. + (sly-send `(:emacs-rex ,form ,package ,thread ,id ,@extra-options)) + (push (cons id continuation) (sly-rex-continuations)) + (sly--refresh-mode-line))) + ((:return value id) + (let ((rec (assq id (sly-rex-continuations)))) + (cond (rec (setf (sly-rex-continuations) + (remove rec (sly-rex-continuations))) + (funcall (cdr rec) value) + (sly--refresh-mode-line)) + (t + (error "Unexpected reply: %S %S" id value))))) + ((:debug-activate thread level &optional _ignored) + (cl-assert thread) + (sly-db--ensure-initialized thread level)) + ((:debug thread level condition restarts frames conts) + (cl-assert thread) + (sly-db-setup thread level condition restarts frames conts)) + ((:debug-return thread level stepping) + (cl-assert thread) + (sly-db-exit thread level stepping)) + ((:emacs-interrupt thread) + (sly-send `(:emacs-interrupt ,thread))) + ((:read-from-minibuffer thread tag prompt initial-value) + (sly-read-from-minibuffer-for-slynk thread tag prompt + initial-value)) + ((:y-or-n-p thread tag question) + (sly-remote-y-or-n-p thread tag question)) + ((:emacs-return-string thread tag string) + (sly-send `(:emacs-return-string ,thread ,tag ,string))) + ((:new-features features) + (setf (sly-lisp-features) features)) + ((:indentation-update info) + (sly-handle-indentation-update info)) + ((:eval-no-wait form) + (sly-check-eval-in-emacs-enabled) + (eval (read form) t)) + ((:eval thread tag form-string) + (sly-check-eval-in-emacs-enabled) + (sly-eval-for-lisp thread tag form-string)) + ((:emacs-return thread tag value) + (sly-send `(:emacs-return ,thread ,tag ,value))) + ((:ed what) + (sly-ed what)) + ((:inspect what thread tag) + (let ((hook (when (and thread tag) + (sly-curry #'sly-send + `(:emacs-return ,thread ,tag nil))))) + (sly--open-inspector what :kill-hook hook :switch :raise))) + ((:background-message message) + (sly-temp-message 1 3 "[background-message] %s" message)) + ((:debug-condition thread message) + (cl-assert thread) + (sly-message "[debug-condition] %s" message)) + ((:ping thread tag) + (sly-send `(:emacs-pong ,thread ,tag))) + ((:reader-error packet condition) + (sly-with-popup-buffer ((sly-buffer-name :error + :connection sly-dispatching-connection)) + (princ (format "Invalid protocol message:\n%s\n\n%s" + condition packet)) + (goto-char (point-min))) + (error "Invalid protocol message")) + ((:invalid-rpc id message) + (setf (sly-rex-continuations) + (cl-remove id (sly-rex-continuations) :key #'car)) + (error "Invalid rpc: %s" message)) + ((:emacs-skipped-packet _pkg)) + ((:test-delay seconds) ; for testing only + (sit-for seconds)) + ((:channel-send id msg) + (sly-channel-send (or (sly-find-channel id) + (error "Invalid channel id: %S %S" id msg)) + msg)) + ((:emacs-channel-send id msg) + (sly-send `(:emacs-channel-send ,id ,msg))) + ((:invalid-channel channel-id reason) + (error "Invalid remote channel %s: %s" channel-id reason)))))) + +(defvar sly--send-last-command nil + "Value of `this-command' at time of last `sly-send' call.") + +(defun sly-send (sexp) + "Send SEXP directly over the wire on the current connection." + (setq sly--send-last-command this-command) + (sly-net-send sexp (sly-connection))) + +(defun sly-reset () + "Clear all pending continuations and erase connection buffer." + (interactive) + (setf (sly-rex-continuations) '()) + (mapc #'kill-buffer (sly-db-buffers)) + (sly-with-connection-buffer () + (erase-buffer))) + +(defun sly-send-sigint () + (interactive) + (signal-process (sly-pid) 'SIGINT)) + +;;;;; Channels + +;;; A channel implements a set of operations. Those operations can be +;;; invoked by sending messages to the channel. Channels are used for +;;; protocols which can't be expressed naturally with RPCs, e.g. for +;;; streaming data over the wire. +;;; +;;; A channel can be "remote" or "local". Remote channels are +;;; represented by integers. Local channels are structures. Messages +;;; sent to a closed (remote) channel are ignored. + +(sly-def-connection-var sly-channels '() + "Alist of the form (ID . CHANNEL).") + +(sly-def-connection-var sly-channels-counter 0 + "Channel serial number counter.") + +(cl-defstruct (sly-channel (:conc-name sly-channel.) + (:constructor + sly-make-channel% (operations name id plist))) + operations name id plist) + +(defun sly-make-channel (operations &optional name) + (let* ((id (cl-incf (sly-channels-counter))) + (ch (sly-make-channel% operations name id nil))) + (push (cons id ch) (sly-channels)) + ch)) + +(defun sly-close-channel (channel) + (setf (sly-channel.operations channel) 'closed-channel) + (let ((probe (assq (sly-channel.id channel) + (and (sly-current-connection) + (sly-channels))))) + (cond (probe (setf (sly-channels) (delete probe (sly-channels)))) + (t (error "Can't close invalid channel: %s" channel))))) + +(defun sly-find-channel (id) + (cdr (assq id (sly-channels)))) + +(defun sly-channel-send (channel message) + (apply (or (gethash (car message) (sly-channel.operations channel)) + (error "Unsupported operation %S for channel %d" + (car message) + (sly-channel.id channel))) + channel (cdr message))) + +(defun sly-channel-put (channel prop value) + (setf (sly-channel.plist channel) + (plist-put (sly-channel.plist channel) prop value))) + +(defun sly-channel-get (channel prop) + (plist-get (sly-channel.plist channel) prop)) + +(eval-and-compile + (defun sly-channel-method-table-name (type) + (intern (format "sly-%s-channel-methods" type)))) + +(defmacro sly-define-channel-type (name) + (declare (indent defun)) + (let ((tab (sly-channel-method-table-name name))) + `(defvar ,tab (make-hash-table :size 10)))) + +(defmacro sly-define-channel-method (type method args &rest body) + (declare (indent 3) (debug (&define sexp name lambda-list + def-body))) + `(puthash ',method + (lambda (self . ,args) ,@body) + ,(sly-channel-method-table-name type))) + +(defun sly-send-to-remote-channel (channel-id msg) + (sly-dispatch-event `(:emacs-channel-send ,channel-id ,msg))) + +;;;;; Event logging to *sly-events* +;;; +;;; The *sly-events* buffer logs all protocol messages for debugging +;;; purposes. + +(defvar sly-log-events t + "*Log protocol events to the *sly-events* buffer.") + +(defun sly-log-event (event process) + "Record the fact that EVENT occurred in PROCESS." + (when sly-log-events + (with-current-buffer (sly--events-buffer process) + ;; trim? + (when (> (buffer-size) 100000) + (goto-char (/ (buffer-size) 2)) + (re-search-forward "^(" nil t) + (delete-region (point-min) (point))) + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (cond ((and (stringp event) + (string-match "^;" event)) + (insert-before-markers event)) + (t + (save-excursion + (sly-pprint-event event (current-buffer))))) + (goto-char (point-max))))) + +(defun sly-pprint-event (event buffer) + "Pretty print EVENT in BUFFER with limited depth and width." + (let ((print-length 20) + (print-level 6) + (pp-escape-newlines t)) + ;; HACK workaround for gh#183 + (condition-case _oops (pp event buffer) (error (print event buffer))))) + +(defun sly--events-buffer (process) + "Return or create the event log buffer." + (let* ((probe (process-get process 'sly--events-buffer)) + (buffer (or (and (buffer-live-p probe) + probe) + (let ((buffer (get-buffer-create + (apply #'sly-buffer-name + :events + (if (sly-connection-name process) + `(:connection ,process) + `(:suffix ,(format "%s" process))))))) + (with-current-buffer buffer + (buffer-disable-undo) + (when (fboundp 'lisp-data-mode) ; Emacs >= 28 only + (funcall 'lisp-data-mode)) + (set (make-local-variable 'sly-buffer-connection) process) + (sly-mode 1)) + (process-put process 'sly--events-buffer buffer) + buffer)))) + buffer)) + +(defun sly-pop-to-events-buffer (process) + "Pop to the SLY events buffer for PROCESS" + (interactive (list (sly-current-connection))) + (pop-to-buffer (sly--events-buffer process))) + +(defun sly-switch-to-most-recent (mode) + "Switch to most recent buffer in MODE, a major-mode symbol. +With prefix argument, prompt for MODE" + (interactive + (list (if current-prefix-arg + (intern (completing-read + "Switch to most recent buffer in what mode? " + (mapcar #'symbol-name '(lisp-mode + emacs-lisp-mode)) + nil t)) + 'lisp-mode))) + (cl-loop for buffer in (buffer-list) + when (and (with-current-buffer buffer (eq major-mode mode)) + (not (eq buffer (current-buffer))) + (not (string-match "^ " (buffer-name buffer)))) + do (pop-to-buffer buffer) and return buffer)) + +(defun sly-forget-pending-events (process) + "Forget any outgoing events for the PROCESS" + (interactive (list (sly-current-connection))) + (setf (sly-rex-continuations process) nil)) + + +;;;;; Cleanup after a quit + +(defun sly-restart-inferior-lisp () + "Kill and restart the Lisp subprocess." + (interactive) + (cl-assert (sly-inferior-process) () "No inferior lisp process") + (sly-quit-lisp-internal (sly-connection) 'sly-restart-sentinel t)) + +(defun sly-restart-sentinel (connection _message) + "When CONNECTION dies, start a similar inferior lisp process. +Also rearrange windows." + (cl-assert (process-status connection) 'closed) + (let* ((moribund-proc (sly-inferior-process connection)) + (args (sly-inferior-lisp-args moribund-proc)) + (buffer (buffer-name (process-buffer moribund-proc)))) + (sly-net-close connection "Restarting inferior lisp process") + (sly-inferior-connect (sly-start-lisp (plist-get args :program) + (plist-get args :program-args) + (plist-get args :env) + nil + buffer) + args))) + + +;;;; Compilation and the creation of compiler-note annotations + +(defvar sly-highlight-compiler-notes t + "*When non-nil annotate buffers with compilation notes etc.") + +(defcustom sly-compilation-finished-hook '(sly-maybe-show-compilation-log) + "Hook called after compilation. +Each function is called with four arguments (SUCCESSP NOTES BUFFER LOADP) +SUCCESSP indicates if the compilation was successful. +NOTES is a list of compilation notes. +BUFFER is the buffer just compiled, or nil if a string was compiled. +LOADP is the value of the LOAD flag passed to `sly-compile-file', or t +if a string." + :group 'sly-mode + :type 'hook + :options '(sly-maybe-show-compilation-log + sly-show-compilation-log + sly-maybe-show-xrefs-for-notes + sly-goto-first-note)) + +;; FIXME: I doubt that anybody uses this directly and it seems to be +;; only an ugly way to pass arguments. +(defvar sly-compilation-policy nil + "When non-nil compile with these optimization settings.") + +(defun sly-compute-policy (arg) + "Return the policy for the prefix argument ARG." + (let ((between (lambda (min n max) + (cond ((< n min) min) + ((> n max) max) + (t n))))) + (let ((n (prefix-numeric-value arg))) + (cond ((not arg) sly-compilation-policy) + ((cl-plusp n) `((cl:debug . ,(funcall between 0 n 3)))) + ((eq arg '-) `((cl:speed . 3))) + (t `((cl:speed . ,(funcall between 0 (abs n) 3)))))))) + +(cl-defstruct (sly-compilation-result + (:type list) + (:conc-name sly-compilation-result.) + (:constructor nil) + (:copier nil)) + tag notes successp duration loadp faslfile) + +(defvar sly-last-compilation-result nil + "The result of the most recently issued compilation.") + +(defun sly-compiler-notes () + "Return all compiler notes, warnings, and errors." + (sly-compilation-result.notes sly-last-compilation-result)) + +(defun sly-compile-and-load-file (&optional policy) + "Compile and load the buffer's file and highlight compiler notes. + +With (positive) prefix argument the file is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign. + +Each source location that is the subject of a compiler note is +underlined and annotated with the relevant information. The commands +`sly-next-note' and `sly-previous-note' can be used to navigate +between compiler notes and to display their full details." + (interactive "P") + (sly-compile-file t (sly-compute-policy policy))) + +(defcustom sly-compile-file-options '() + "Plist of additional options that C-c C-k should pass to Lisp. +Currently only :fasl-directory is supported." + :group 'sly-lisp + :type '(plist :key-type symbol :value-type (file :must-match t))) + +(defun sly-compile-file (&optional load policy) + "Compile current buffer's file and highlight resulting compiler notes. + +See `sly-compile-and-load-file' for further details." + (interactive) + (unless buffer-file-name + (error "Buffer %s is not associated with a file." (buffer-name))) + (check-parens) + (when (and (buffer-modified-p) + (or (not compilation-ask-about-save) + (sly-y-or-n-p (format "Save file %s? " (buffer-file-name))))) + (save-buffer)) + (let ((file (sly-to-lisp-filename (buffer-file-name))) + (options (sly-simplify-plist `(,@sly-compile-file-options + :policy ,policy)))) + (sly-eval-async + `(slynk:compile-file-for-emacs ,file ,(if load t nil) + . ,(sly-hack-quotes options)) + #'(lambda (result) + (sly-compilation-finished result (current-buffer)))) + (sly-message "Compiling %s..." file))) + +(defun sly-hack-quotes (arglist) + ;; eval is the wrong primitive, we really want funcall + (cl-loop for arg in arglist collect `(quote ,arg))) + +(defun sly-simplify-plist (plist) + (cl-loop for (key val) on plist by #'cddr + append (cond ((null val) '()) + (t (list key val))))) + +(defun sly-compile-defun (&optional raw-prefix-arg) + "Compile the current toplevel form. + +With (positive) prefix argument the form is compiled with maximal +debug settings (`C-u'). With negative prefix argument it is compiled for +speed (`M--'). If a numeric argument is passed set debug or speed settings +to it depending on its sign." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (if (use-region-p) + (sly-compile-region (region-beginning) (region-end)) + (apply #'sly-compile-region (sly-region-for-defun-at-point))))) + +(defvar sly-compile-region-function 'sly-compile-region-as-string + "Function called by `sly-compile-region' to do actual work.") + +(defun sly-compile-region (start end) + "Compile the region." + (interactive "r") + ;; Check connection before running hooks things like + ;; sly-flash-region don't make much sense if there's no connection + (sly-connection) + (funcall sly-compile-region-function start end)) + +(defun sly-compile-region-as-string (start end) + (sly-flash-region start end) + (sly-compile-string (buffer-substring-no-properties start end) start)) + +(defun sly-compile-string (string start-offset) + (let* ((position (sly-compilation-position start-offset))) + (sly-eval-async + `(slynk:compile-string-for-emacs + ,string + ,(buffer-name) + ',position + ,(if (buffer-file-name) (sly-to-lisp-filename (buffer-file-name))) + ',sly-compilation-policy) + #'(lambda (result) + (sly-compilation-finished result nil))))) + +(defun sly-compilation-position (start-offset) + (let ((line (save-excursion + (goto-char start-offset) + (list (line-number-at-pos) (1+ (current-column)))))) + `((:position ,start-offset) (:line ,@line)))) + +(defcustom sly-load-failed-fasl 'never + "Which action to take when COMPILE-FILE set FAILURE-P to T. +NEVER doesn't load the fasl +ALWAYS loads the fasl +ASK asks the user." + :type '(choice (const never) + (const always) + (const ask))) + +(defun sly-load-failed-fasl-p () + (cl-ecase sly-load-failed-fasl + (never nil) + (always t) + (ask (sly-y-or-n-p "Compilation failed. Load fasl file anyway? ")))) + +(defun sly-compilation-finished (result buffer &optional message) + (let ((notes (sly-compilation-result.notes result)) + (duration (sly-compilation-result.duration result)) + (successp (sly-compilation-result.successp result)) + (faslfile (sly-compilation-result.faslfile result)) + (loadp (sly-compilation-result.loadp result))) + (setf sly-last-compilation-result result) + (sly-show-note-counts notes duration (cond ((not loadp) successp) + (t (and faslfile successp))) + (or (not buffer) loadp) + message) + (when sly-highlight-compiler-notes + (sly-highlight-notes notes)) + (when (and loadp faslfile + (or successp + (sly-load-failed-fasl-p))) + (sly-eval-async `(slynk:load-file ,faslfile))) + (run-hook-with-args 'sly-compilation-finished-hook successp notes buffer loadp))) + +(defun sly-show-note-counts (notes secs successp loadp &optional message) + (sly-message (concat + (cond ((and successp loadp) + "Compiled and loaded") + (successp "Compilation finished") + (t (sly-add-face 'font-lock-warning-face + "Compilation failed"))) + (if (null notes) ". (No warnings)" ": ") + (mapconcat + (lambda (msgs) + (cl-destructuring-bind (sev . notes) msgs + (let ((len (length notes))) + (format "%d %s%s" len (sly-severity-label sev) + (if (= len 1) "" "s"))))) + (sort (sly-alistify notes #'sly-note.severity #'eq) + (lambda (x y) (sly-severity< (car y) (car x)))) + " ") + (if secs (format " [%.2f secs]" secs)) + message))) + +(defun sly-highlight-notes (notes) + "Highlight compiler notes, warnings, and errors in the buffer." + (interactive (list (sly-compiler-notes))) + (with-temp-message "Highlighting notes..." + (save-excursion + (save-restriction + (widen) ; highlight notes on the whole buffer + (sly-remove-notes (point-min) (point-max)) + (mapc #'sly--add-in-buffer-note notes))))) + + +;;;;; Recompilation. + +;; FIXME: This whole idea is questionable since it depends so +;; crucially on precise source-locs. + +(defun sly-recompile-location (location) + (save-excursion + (sly-move-to-source-location location) + (sly-compile-defun))) + +(defun sly-recompile-locations (locations cont) + (sly-eval-async + `(slynk:compile-multiple-strings-for-emacs + ',(cl-loop for loc in locations collect + (save-excursion + (sly-move-to-source-location loc) + (cl-destructuring-bind (start end) + (sly-region-for-defun-at-point) + (list (buffer-substring-no-properties start end) + (buffer-name) + (sly-current-package) + start + (if (buffer-file-name) + (sly-to-lisp-filename (buffer-file-name)) + nil))))) + ',sly-compilation-policy) + cont)) + + +;;;;; Compiler notes list + +(defun sly-one-line-ify (string) + "Return a single-line version of STRING. +Each newlines and following indentation is replaced by a single space." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "\n[\n \t]*" nil t) + (replace-match " ")) + (buffer-string))) + +(defun sly-xref--get-xrefs-for-notes (notes) + (let ((xrefs)) + (dolist (note notes) + (let* ((location (cl-getf note :location)) + (fn (cadr (assq :file (cdr location)))) + (file (assoc fn xrefs)) + (node + (list (format "%s: %s" + (cl-getf note :severity) + (sly-one-line-ify (cl-getf note :message))) + location))) + (when fn + (if file + (push node (cdr file)) + (setf xrefs (cl-acons fn (list node) xrefs)))))) + xrefs)) + +(defun sly-maybe-show-xrefs-for-notes (_successp notes _buffer _loadp) + "Show the compiler notes NOTES if they come from more than one file." + (let ((xrefs (sly-xref--get-xrefs-for-notes notes))) + (when (cdr xrefs) ; >1 file + (sly-xref--show-results + xrefs 'definition "Compiler notes" (sly-current-package))))) + +(defun sly-maybe-show-compilation-log (successp notes buffer loadp) + "Display the log on failed compilations or if NOTES is non-nil." + (sly-show-compilation-log successp notes buffer loadp + (if successp :hidden nil))) + +(defun sly-show-compilation-log (successp notes buffer loadp &optional select) + "Create and display the compilation log buffer." + (interactive (list (sly-compiler-notes))) + (sly-with-popup-buffer ((sly-buffer-name :compilation) + :mode 'compilation-mode + :select select) + (sly--insert-compilation-log successp notes buffer loadp) + (insert "Compilation " + (if successp "successful" "failed") + "."))) + +(defvar sly-compilation-log--notes (make-hash-table) + "Hash-table (NOTE -> (BUFFER POSITION)) for finding notes in + the SLY compilation log") + +(defun sly--insert-compilation-log (_successp notes _buffer _loadp) + "Insert NOTES in format suitable for `compilation-mode'." + (clrhash sly-compilation-log--notes) + (cl-multiple-value-bind (grouped-notes canonicalized-locs-table) + (sly-group-and-sort-notes notes) + (with-temp-message "Preparing compilation log..." + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) ; inefficient font-lock-hook + (insert (format "cd %s\n%d compiler notes:\n\n" + default-directory (length notes))) + (cl-loop for notes in grouped-notes + for loc = (gethash (cl-first notes) canonicalized-locs-table) + for start = (point) + do + (cl-loop for note in notes + do (puthash note + (cons (current-buffer) start) + sly-compilation-log--notes)) + (insert + (sly--compilation-note-group-button + (sly-canonicalized-location-to-string loc) notes) + ":") + (sly-insert-note-group notes) + (insert "\n") + (add-text-properties start (point) `(field ,notes)))) + (set (make-local-variable 'compilation-skip-threshold) 0) + (setq next-error-last-buffer (current-buffer))))) + +(defun sly-insert-note-group (notes) + "Insert a group of compiler messages." + (insert "\n") + (dolist (note notes) + (insert " " (sly-severity-label (sly-note.severity note)) ": ") + (let ((start (point))) + (insert (sly-note.message note)) + (let ((ctx (sly-note.source-context note))) + (if ctx (insert "\n" ctx))) + (sly-indent-block start 4)) + (insert "\n"))) + +(defun sly-indent-block (start column) + "If the region back to START isn't a one-liner indent it." + (when (< start (line-beginning-position)) + (save-excursion + (goto-char start) + (insert "\n")) + (sly-indent-rigidly start (point) column))) + +(defun sly-canonicalized-location (location) + "Return a list (FILE LINE COLUMN) for sly-location LOCATION. +This is quite an expensive operation so use carefully." + (save-excursion + (sly-goto-location-buffer (sly-location.buffer location)) + (save-excursion + (sly-move-to-source-location location) + (list (or (buffer-file-name) (buffer-name)) + (save-restriction + (widen) + (line-number-at-pos)) + (1+ (current-column)))))) + +(defun sly-canonicalized-location-to-string (loc) + (if loc + (cl-destructuring-bind (filename line col) loc + (format "%s:%d:%d" + (cond ((not filename) "") + ((let ((rel (file-relative-name filename))) + (if (< (length rel) (length filename)) + rel))) + (t filename)) + line col)) + (format "Unknown location"))) + +(defun sly-group-and-sort-notes (notes) + "First sort, then group NOTES according to their canonicalized locs." + (let ((locs (make-hash-table :test #'eq))) + (mapc (lambda (note) + (let ((loc (sly-note.location note))) + (when (sly-location-p loc) + (puthash note (sly-canonicalized-location loc) locs)))) + notes) + (cl-values (sly-group-similar + (lambda (n1 n2) + (equal (gethash n1 locs nil) (gethash n2 locs t))) + (let* ((bottom most-negative-fixnum) + (+default+ (list "" bottom bottom))) + (sort notes + (lambda (n1 n2) + (cl-destructuring-bind (filename1 line1 col1) + (gethash n1 locs +default+) + (cl-destructuring-bind (filename2 line2 col2) + (gethash n2 locs +default+) + (cond ((string-lessp filename1 filename2) t) + ((string-lessp filename2 filename1) nil) + ((< line1 line2) t) + ((> line1 line2) nil) + (t (< col1 col2))))))))) + locs))) + +(defun sly-note.severity (note) + (plist-get note :severity)) + +(defun sly-note.message (note) + (plist-get note :message)) + +(defun sly-note.source-context (note) + (plist-get note :source-context)) + +(defun sly-note.location (note) + (plist-get note :location)) + +(defun sly-severity-label (severity) + (cl-subseq (symbol-name severity) 1)) + + + +;;;;; Adding a single compiler note +;;;;; +(defun sly-choose-overlay-region (note) + "Choose the start and end points for an overlay over NOTE. +If the location's sexp is a list spanning multiple lines, then the +region around the first element is used. +Return nil if there's no useful source location." + (let ((location (sly-note.location note))) + (when location + (sly-dcase location + ((:error _)) ; do nothing + ((:location file pos _hints) + (cond ((eq (car file) ':source-form) nil) + ((eq (sly-note.severity note) :read-error) + (sly-choose-overlay-for-read-error location)) + ((equal pos '(:eof)) + (list (1- (point-max)) (point-max))) + (t + (sly-choose-overlay-for-sexp location)))))))) + +(defun sly-choose-overlay-for-read-error (location) + (let ((pos (sly-location-offset location))) + (save-excursion + (goto-char pos) + (cond ((sly-symbol-at-point) + ;; package not found, &c. + (list (sly-symbol-start-pos) (sly-symbol-end-pos))) + (t + (list pos (1+ pos))))))) + +(defun sly-choose-overlay-for-sexp (location) + (sly-move-to-source-location location) + (skip-chars-forward "'#`") + (let ((start (point))) + (ignore-errors (sly-forward-sexp)) + (if (sly-same-line-p start (point)) + (list start (point)) + (list (1+ start) + (progn (goto-char (1+ start)) + (ignore-errors (forward-sexp 1)) + (point)))))) +(defun sly-same-line-p (pos1 pos2) + "Return t if buffer positions POS1 and POS2 are on the same line." + (save-excursion (goto-char (min pos1 pos2)) + (<= (max pos1 pos2) (line-end-position)))) + +(defvar sly-severity-face-plist + (list :error 'sly-error-face + :read-error 'sly-error-face + :warning 'sly-warning-face + :redefinition 'sly-style-warning-face + :style-warning 'sly-style-warning-face + :note 'sly-note-face)) + +(defun sly-severity-face (severity) + "Return the name of the font-lock face representing SEVERITY." + (or (plist-get sly-severity-face-plist severity) + (error "No face for: %S" severity))) + +(defvar sly-severity-order + '(:note :style-warning :redefinition :warning :error :read-error)) + +(defun sly-severity< (sev1 sev2) + "Return true if SEV1 is less severe than SEV2." + (< (cl-position sev1 sly-severity-order) + (cl-position sev2 sly-severity-order))) + +(defun sly-forward-positioned-source-path (source-path) + "Move forward through a sourcepath from a fixed position. +The point is assumed to already be at the outermost sexp, making the +first element of the source-path redundant." + (ignore-errors + (sly-forward-sexp) + (beginning-of-defun)) + (sly--when-let (source-path (cdr source-path)) + (down-list 1) + (sly-forward-source-path source-path))) + +(defun sly-forward-source-path (source-path) + (let ((origin (point))) + (condition-case nil + (progn + (cl-loop for (count . more) on source-path + do (progn + (sly-forward-sexp count) + (when more (down-list 1)))) + ;; Align at beginning + (sly-forward-sexp) + (beginning-of-sexp)) + (error (goto-char origin))))) + + +;; FIXME: really fix this mess +;; FIXME: the check shouln't be done here anyway but by M-. itself. + +(defun sly-filesystem-toplevel-directory () + ;; Windows doesn't have a true toplevel root directory, and all + ;; filenames look like "c:/foo/bar/quux.baz" from an Emacs + ;; perspective anyway. + (if (memq system-type '(ms-dos windows-nt)) + "" + (file-name-as-directory "/"))) + +(defun sly-file-name-merge-source-root (target-filename buffer-filename) + "Returns a filename where the source root directory of TARGET-FILENAME +is replaced with the source root directory of BUFFER-FILENAME. + +If no common source root could be determined, return NIL. + +E.g. (sly-file-name-merge-source-root + \"/usr/local/src/joe/upstream/sbcl/code/late-extensions.lisp\" + \"/usr/local/src/joe/hacked/sbcl/compiler/deftype.lisp\") + + ==> \"/usr/local/src/joe/hacked/sbcl/code/late-extensions.lisp\" +" + (let ((target-dirs (split-string (file-name-directory target-filename) + "/" t)) + (buffer-dirs (split-string (file-name-directory buffer-filename) + "/" t))) + ;; Starting from the end, we look if one of the TARGET-DIRS exists + ;; in BUFFER-FILENAME---if so, it and everything left from that dirname + ;; is considered to be the source root directory of BUFFER-FILENAME. + (cl-loop with target-suffix-dirs = nil + with buffer-dirs* = (reverse buffer-dirs) + with target-dirs* = (reverse target-dirs) + for target-dir in target-dirs* + do (let ((concat-dirs (lambda (dirs) + (apply #'concat + (mapcar #'file-name-as-directory + dirs)))) + (pos (cl-position target-dir buffer-dirs* + :test #'equal))) + (if (not pos) ; TARGET-DIR not in BUFFER-FILENAME? + (push target-dir target-suffix-dirs) + (let* ((target-suffix + ; PUSH reversed for us! + (funcall concat-dirs target-suffix-dirs)) + (buffer-root + (funcall concat-dirs + (reverse (nthcdr pos buffer-dirs*))))) + (cl-return (concat (sly-filesystem-toplevel-directory) + buffer-root + target-suffix + (file-name-nondirectory + target-filename))))))))) + +(defun sly-highlight-differences-in-dirname (base-dirname contrast-dirname) + "Returns a copy of BASE-DIRNAME where all differences between +BASE-DIRNAME and CONTRAST-DIRNAME are propertized with a +highlighting face." + (setq base-dirname (file-name-as-directory base-dirname)) + (setq contrast-dirname (file-name-as-directory contrast-dirname)) + (let ((base-dirs (split-string base-dirname "/" t)) + (contrast-dirs (split-string contrast-dirname "/" t))) + (with-temp-buffer + (cl-loop initially (insert (sly-filesystem-toplevel-directory)) + for base-dir in base-dirs do + (let ((pos (cl-position base-dir contrast-dirs :test #'equal))) + (cond ((not pos) + (sly-insert-propertized '(face highlight) base-dir) + (insert "/")) + (t + (insert (file-name-as-directory base-dir)) + (setq contrast-dirs + (nthcdr (1+ pos) contrast-dirs)))))) + (buffer-substring (point-min) (point-max))))) + +(defvar sly-warn-when-possibly-tricked-by-M-. t + "When working on multiple source trees simultaneously, the way +`sly-edit-definition' (M-.) works can sometimes be confusing: + +`M-.' visits locations that are present in the current Lisp image, +which works perfectly well as long as the image reflects the source +tree that one is currently looking at. + +In the other case, however, one can easily end up visiting a file +in a different source root directory (the one corresponding to +the Lisp image), and is thus easily tricked to modify the wrong +source files---which can lead to quite some stressfull cursing. + +If this variable is T, a warning message is issued to raise the +user's attention whenever `M-.' is about opening a file in a +different source root that also exists in the source root +directory of the user's current buffer. + +There's no guarantee that all possible cases are covered, but +if you encounter such a warning, it's a strong indication that +you should check twice before modifying.") + +(defun sly-maybe-warn-for-different-source-root (target-filename + buffer-filename) + (let ((guessed-target (sly-file-name-merge-source-root target-filename + buffer-filename))) + (when (and guessed-target + (not (equal guessed-target target-filename)) + (file-exists-p guessed-target)) + (sly-message "Attention: This is `%s'." + (concat (sly-highlight-differences-in-dirname + (file-name-directory target-filename) + (file-name-directory guessed-target)) + (file-name-nondirectory target-filename)))))) + +(defun sly-check-location-filename-sanity (filename) + (when sly-warn-when-possibly-tricked-by-M-. + (cl-macrolet ((truename-safe (file) `(and ,file (file-truename ,file)))) + (let ((target-filename (truename-safe filename)) + (buffer-filename (truename-safe (buffer-file-name)))) + (when (and target-filename + buffer-filename) + (sly-maybe-warn-for-different-source-root + target-filename buffer-filename)))))) + +(defun sly-check-location-buffer-name-sanity (buffer-name) + (sly-check-location-filename-sanity + (buffer-file-name (get-buffer buffer-name)))) + + + +(defun sly-goto-location-buffer (buffer) + (sly-dcase buffer + ((:file filename) + (let ((filename (sly-from-lisp-filename filename))) + (sly-check-location-filename-sanity filename) + (set-buffer (or (get-file-buffer filename) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect filename)))))) + ((:buffer buffer-name) + (sly-check-location-buffer-name-sanity buffer-name) + (set-buffer buffer-name)) + ((:buffer-and-file buffer filename) + (sly-goto-location-buffer + (if (get-buffer buffer) + (list :buffer buffer) + (list :file filename)))) + ((:source-form string) + (set-buffer (get-buffer-create (sly-buffer-name :source))) + (erase-buffer) + (lisp-mode) + (insert string) + (goto-char (point-min))) + ((:zip file entry) + (require 'arc-mode) + (set-buffer (find-file-noselect file t)) + (goto-char (point-min)) + (re-search-forward (concat " " entry "$")) + (let ((buffer (save-window-excursion + (archive-extract) + (current-buffer)))) + (set-buffer buffer) + (goto-char (point-min)))))) + +(defun sly-goto-location-position (position) + (sly-dcase position + ((:position pos) + (goto-char 1) + (forward-char (- (1- pos) (sly-eol-conversion-fixup (1- pos))))) + ((:offset start offset) + (goto-char start) + (forward-char offset)) + ((:line start &optional column) + (goto-char (point-min)) + (beginning-of-line start) + (cond (column (move-to-column column)) + (t (skip-chars-forward " \t")))) + ((:function-name name) + (let ((case-fold-search t) + (name (regexp-quote name))) + (goto-char (point-min)) + (when (or + (re-search-forward + (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +(*%s\\S_" + (regexp-quote name)) nil t) + (re-search-forward + (format "[( \t]%s\\>\\(\\s \\|$\\)" name) nil t)) + (goto-char (match-beginning 0))))) + ((:method name specializers &rest qualifiers) + (sly-search-method-location name specializers qualifiers)) + ((:source-path source-path start-position) + (cond (start-position + (goto-char start-position) + (sly-forward-positioned-source-path source-path)) + (t + (sly-forward-source-path source-path)))) + ((:eof) + (goto-char (point-max))))) + +(defun sly-eol-conversion-fixup (n) + ;; Return the number of \r\n eol markers that we need to cross when + ;; moving N chars forward. N is the number of chars but \r\n are + ;; counted as 2 separate chars. + (if (zerop n) 0 + (cl-case (coding-system-eol-type buffer-file-coding-system) + ((1) + (save-excursion + (cl-do ((pos (+ (point) n)) + (count 0 (1+ count))) + ((>= (point) pos) (1- count)) + (forward-line) + (cl-decf pos)))) + (t 0)))) + +(defun sly-search-method-location (name specializers qualifiers) + ;; Look for a sequence of words (def method name + ;; qualifers specializers don't look for "T" since it isn't requires + ;; (arg without t) as class is taken as such. + (let* ((case-fold-search t) + (name (regexp-quote name)) + (qualifiers (mapconcat (lambda (el) (concat ".+?\\<" el "\\>")) + qualifiers "")) + (specializers (mapconcat + (lambda (el) + (if (eql (aref el 0) ?\() + (let ((spec (read el))) + (if (eq (car spec) 'EQL) + (concat + ".*?\\n\\{0,1\\}.*?(EQL.*?'\\{0,1\\}" + (format "%s" (cl-second spec)) ")") + (error "don't understand specializer: %s,%s" + el (car spec)))) + (concat ".+?\n\\{0,1\\}.+?\\<" el "\\>"))) + (remove "T" specializers) "")) + (regexp (format "\\s *(def\\(\\s_\\|\\sw\\)*\\s +%s\\s +%s%s" name + qualifiers specializers))) + (or (and (re-search-forward regexp nil t) + (goto-char (match-beginning 0))) + ;; (sly-goto-location-position `(:function-name ,name)) + ))) + +(defun sly-search-call-site (fname) + "Move to the place where FNAME called. +Don't move if there are multiple or no calls in the current defun." + (save-restriction + (narrow-to-defun) + (let ((start (point)) + (regexp (concat "(" fname "[)\n \t]")) + (case-fold-search t)) + (cond ((and (re-search-forward regexp nil t) + (not (re-search-forward regexp nil t))) + (goto-char (match-beginning 0))) + (t (goto-char start)))))) + +(defun sly-search-edit-path (edit-path) + "Move to EDIT-PATH starting at the current toplevel form." + (when edit-path + (unless (and (= (current-column) 0) + (looking-at "(")) + (beginning-of-defun)) + (sly-forward-source-path edit-path))) + +(defun sly-move-to-source-location (location &optional noerror) + "Move to the source location LOCATION. +If NOERROR don't signal an error, but return nil. + +Several kinds of locations are supported: + + ::= (:location ) + | (:error ) + + ::= (:file ) + | (:buffer ) + | (:buffer-and-file ) + | (:source-form ) + | (:zip ) + + ::= (:position ) ; 1 based (for files) + | (:offset ) ; start+offset (for C-c C-c) + | (:line []) + | (:function-name ) + | (:source-path ) + | (:method . )" + (sly-dcase location + ((:location buffer _position _hints) + (sly-goto-location-buffer buffer) + (let ((pos (sly-location-offset location))) + (cond ((and (<= (point-min) pos) (<= pos (point-max)))) + (widen-automatically (widen)) + (t + (error "Location is outside accessible part of buffer"))) + (goto-char pos))) + ((:error message) + (cond (noerror + (sly-message "%s" message) + nil) + (t + (error "%s" message)))))) + +(defun sly--highlight-sexp (&optional start end) + "Highlight the first sexp after point." + (let ((start (or start (point))) + (end (or end (save-excursion (ignore-errors (forward-sexp)) (point))))) + (sly-flash-region start end))) + +(defun sly--highlight-line (&optional timeout) + (sly-flash-region (+ (line-beginning-position) (current-indentation)) + (line-end-position) + :timeout timeout)) + +(make-variable-buffer-local + (defvar sly-xref--popup-method nil + "Helper for `sly--display-source-location'")) + +(cl-defun sly--display-source-location (source-location + &optional noerror (method 'window)) + "Display SOURCE-LOCATION in a window according to METHOD. +Highlight the resulting sexp. Return the window or raise an +error, unless NOERROR is nil, in which case return nil. METHOD +specifies how to behave when a reference is selected in an xref +buffer. If one of symbols `window' or `frame' just +`display-buffer' accordingly. If nil, just switch to buffer in +current window. If a cons (WINDOW . METHOD) consider WINDOW the +\"starting window\" and reconsider METHOD like above: If it is +nil try to use WINDOW exclusively for showing the location, +otherwise prevent that window from being reused when popping to a +new window or frame." + (cl-labels + ((pop-it + (target-buffer method) + (cond ((eq method 'window) + (display-buffer target-buffer t)) + ((eq method 'frame) + (let ((pop-up-frames t)) + (display-buffer target-buffer t))) + ((consp method) + (let* ((window (car method)) + (sub-method (cdr method))) + (cond ((not (window-live-p window)) + ;; the original window has been deleted: all + ;; bets are off! + ;; + (pop-it target-buffer sub-method)) + (sub-method + ;; shield window from reuse, but restoring + ;; any dedicatedness + ;; + (let ((dedicatedness (window-dedicated-p window))) + (unwind-protect + (progn + ;; (set-window-dedicated-p window 'soft) + ;; + ;; jt@2018-01-27 commented the line + ;; above because since the fix to + ;; emacs' bug#28814 in Emacs 26.1 + ;; (which I myself authored), it won't + ;; work correctly. Best to disable it + ;; for now and eventually copy Emacs's + ;; approach to xref buffers, or better + ;; yet, reuse it. + (pop-it target-buffer sub-method)) + (set-window-dedicated-p window dedicatedness)))) + (t + ;; make efforts to reuse the window, respecting + ;; any `display-buffer' overrides + ;; + (display-buffer + target-buffer + `(,(lambda (buffer _alist) + (when (window-live-p window) + (set-window-buffer window buffer) + window)))))))) + (t + (switch-to-buffer target-buffer) + (selected-window))))) + (when (eq method 'sly-xref) + (setq method sly-xref--popup-method)) + (when (sly-move-to-source-location source-location noerror) + (let ((pos (point))) + (with-selected-window (pop-it (current-buffer) method) + (goto-char pos) + (recenter (if (= (current-column) 0) 1)) + (sly--highlight-sexp) + (selected-window)))))) + +(defun sly--pop-to-source-location (source-location &optional method) + "Pop to SOURCE-LOCATION using METHOD. +If called from an xref buffer, method will be `sly-xref' and +thus also honour `sly-xref--popup-method'." + (let* ((xref-window (selected-window)) + (xref-buffer (window-buffer xref-window))) + (when (eq method 'sly-xref) + (quit-restore-window xref-window 'bury)) + (with-current-buffer xref-buffer + ;; now pop to target + ;; + (select-window + (sly--display-source-location source-location nil method))) + (set-buffer (window-buffer (selected-window))))) + +(defun sly-location-offset (location) + "Return the position, as character number, of LOCATION." + (save-restriction + (widen) + (condition-case nil + (sly-goto-location-position + (sly-location.position location)) + (error (goto-char 0))) + (let ((hints (sly-location.hints location))) + (sly--when-let (snippet (cl-getf hints :snippet)) + (sly-isearch snippet)) + (sly--when-let (snippet (cl-getf hints :edit-path)) + (sly-search-edit-path snippet)) + (sly--when-let (fname (cl-getf hints :call-site)) + (sly-search-call-site fname)) + (when (cl-getf hints :align) + (sly-forward-sexp) + (beginning-of-sexp))) + (point))) + + +;;;;; Incremental search +;; +;; Search for the longest match of a string in either direction. +;; +;; This is for locating text that is expected to be near the point and +;; may have been modified (but hopefully not near the beginning!) + +(defun sly-isearch (string) + "Find the longest occurence of STRING either backwards of forwards. +If multiple matches exist the choose the one nearest to point." + (goto-char + (let* ((start (point)) + (len1 (sly-isearch-with-function 'search-forward string)) + (pos1 (point))) + (goto-char start) + (let* ((len2 (sly-isearch-with-function 'search-backward string)) + (pos2 (point))) + (cond ((and len1 len2) + ;; Have a match in both directions + (cond ((= len1 len2) + ;; Both are full matches -- choose the nearest. + (if (< (abs (- start pos1)) + (abs (- start pos2))) + pos1 pos2)) + ((> len1 len2) pos1) + ((> len2 len1) pos2))) + (len1 pos1) + (len2 pos2) + (t start)))))) + +(defun sly-isearch-with-function (search-fn string) + "Search for the longest substring of STRING using SEARCH-FN. +SEARCH-FN is either the symbol `search-forward' or `search-backward'." + (unless (string= string "") + (cl-loop for i from 1 to (length string) + while (funcall search-fn (substring string 0 i) nil t) + for match-data = (match-data) + do (cl-case search-fn + (search-forward (goto-char (match-beginning 0))) + (search-backward (goto-char (1+ (match-end 0))))) + finally (cl-return (if (null match-data) + nil + ;; Finish based on the last successful match + (store-match-data match-data) + (goto-char (match-beginning 0)) + (- (match-end 0) (match-beginning 0))))))) + + +;;;;; Visiting and navigating the overlays of compiler notes +(defun sly-note-button-p (button) + (eq (button-type button) 'sly-in-buffer-note)) + +(defalias 'sly-next-note 'sly-button-forward) +(defalias 'sly-previous-note 'sly-button-backward) + +(put 'sly-next-note 'sly-button-navigation-command t) +(put 'sly-previous-note 'sly-button-navigation-command t) + +(defun sly-goto-first-note (_successp notes _buffer _loadp) + "Go to the first note in the buffer." + (interactive (list (sly-compiler-notes))) + (when notes + (goto-char (point-min)) + (sly-next-note 1))) + +(defun sly-remove-notes (beg end) + "Remove `sly-note' annotation buttons from BEG to END." + (interactive (if (region-active-p) + (list (region-beginning) (region-end)) + (list (point-min) (point-max)))) + (cl-loop for existing in (overlays-in beg end) + when (sly-note-button-p existing) + do (delete-overlay existing))) + +(defun sly-show-notes (button &rest more-buttons) + "Present the details of a compiler note to the user." + (interactive) + (let ((notes (mapcar (sly-rcurry #'button-get 'sly-note) + (cons button more-buttons)))) + (sly-button-flash button :face (let ((color (face-underline-p (button-get button 'face)))) + (if color `(:background ,color) 'highlight))) + ;; If the compilation window is showing, try to land in a suitable + ;; place there, too... + ;; + (let* ((anchor (car notes)) + (compilation-buffer (sly-buffer-name :compilation)) + (compilation-window (get-buffer-window compilation-buffer t))) + (if compilation-window + (with-current-buffer compilation-buffer + (with-selected-window compilation-window + (let ((buffer-and-pos (gethash anchor + sly-compilation-log--notes))) + (when buffer-and-pos + (cl-assert (eq (car buffer-and-pos) (current-buffer))) + (goto-char (cdr buffer-and-pos)) + (let ((field-end (field-end (1+ (point))))) + (sly-flash-region (point) field-end) + (sly-recenter field-end)))) + (sly-message "Showing note in %s" (current-buffer)))) + ;; Else, do the next best thing, which is echo the messages. + ;; + (if (cdr notes) + (sly-message "%s notes:\n%s" + (length notes) + (mapconcat #'sly-note.message notes "\n")) + (sly-message "%s" (sly-note.message (car notes)))))))) + +(define-button-type 'sly-note :supertype 'sly-button) + +(define-button-type 'sly-in-buffer-note :supertype 'sly-note + 'keymap (let ((map (copy-keymap button-map))) + (define-key map "RET" nil) + map) + 'mouse-action 'sly-show-notes + 'sly-button-echo 'sly-show-notes + 'modification-hooks '(sly--in-buffer-note-modification)) + +(define-button-type 'sly-compilation-note-group :supertype 'sly-note + 'face nil) + +(defun sly--in-buffer-note-modification (button after? _beg _end &optional _len) + (unless after? (delete-overlay button))) + +(defun sly--add-in-buffer-note (note) + "Add NOTE as a `sly-in-buffer-note' button to the source buffer." + (cl-destructuring-bind (&optional beg end) + (sly-choose-overlay-region note) + (when beg + (let* ((contained (sly-button--overlays-between beg end)) + (containers (cl-set-difference (sly-button--overlays-at beg) + contained))) + (cl-loop for ov in contained do (cl-incf (sly-button--level ov))) + (let ((but (make-button beg + end + :type 'sly-in-buffer-note + 'sly-button-search-id (sly-button-next-search-id) + 'sly-note note + 'help-echo (format "[sly] %s" (sly-note.message note)) + 'face (sly-severity-face (sly-note.severity note))))) + (setf (sly-button--level but) + (1+ (cl-reduce #'max containers + :key #'sly-button--level + :initial-value 0)))))))) + +(defun sly--compilation-note-group-button (label notes) + "Pepare notes as a `sly-compilation-note' button. +For insertion in the `compilation-mode' buffer" + (sly--make-text-button label nil :type 'sly-compilation-note-group 'sly-notes-group notes)) + + +;;;; Basic arglisting +;;;; +(defun sly-show-arglist () + (let ((op (ignore-errors + (save-excursion + (backward-up-list 1) + (down-list 1) + (sly-symbol-at-point))))) + (when op + (sly-eval-async `(slynk:operator-arglist ,op ,(sly-current-package)) + (lambda (arglist) + (when arglist + (sly-message "%s" arglist))))))) + + +;;;; Edit definition + +(defun sly-push-definition-stack () + "Add point to find-tag-marker-ring." + (require 'etags) + (if (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack) + (ring-insert find-tag-marker-ring (point-marker)))) + +(defun sly-pop-find-definition-stack () + "Pop the edit-definition stack and goto the location." + (interactive) + (pop-tag-mark)) + +(cl-defstruct (sly-xref (:conc-name sly-xref.) (:type list)) + dspec location) + +(cl-defstruct (sly-location (:conc-name sly-location.) (:type list) + (:constructor nil) + (:copier nil)) + tag buffer position hints) + +(defun sly-location-p (o) (and (consp o) (eq (car o) :location))) + +(defun sly-xref-has-location-p (xref) + (sly-location-p (sly-xref.location xref))) + +(defun make-sly-buffer-location (buffer-name position &optional hints) + `(:location (:buffer ,buffer-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + +(defun make-sly-file-location (file-name position &optional hints) + `(:location (:file ,file-name) (:position ,position) + ,(when hints `(:hints ,hints)))) + + + +(defun sly-edit-definition (&optional name method) + "Lookup the definition of the name at point. +If there's no name at point, or a prefix argument is given, then +the function name is prompted. METHOD can be nil, or one of +`window' or `frame' to specify if the new definition should be +popped, respectively, in the current window, a new window, or a +new frame." + (interactive (list (or (and (not current-prefix-arg) + (sly-symbol-at-point t)) + (sly-read-symbol-name "Edit Definition of: ")))) + ;; The hooks might search for a name in a different manner, so don't + ;; ask the user if it's missing before the hooks are run + (let ((xrefs (sly-eval `(slynk:find-definitions-for-emacs ,name)))) + (unless xrefs + (error "No known definition for: %s (in %s)" + name (sly-current-package))) + (cl-destructuring-bind (1loc file-alist) + (sly-analyze-xrefs xrefs) + (cond (1loc + (sly-push-definition-stack) + (sly--pop-to-source-location + (sly-xref.location (car xrefs)) method)) + ((null (cdr xrefs)) ; ((:error "...")) + (error "%s" xrefs)) + (t + (sly-push-definition-stack) + (sly-xref--show-results file-alist 'definition name + (sly-current-package) + (cons (selected-window) + method))))))) + +(defvar sly-edit-uses-xrefs + '(:calls :macroexpands :binds :references :sets :specializes)) + +;;; FIXME. TODO: Would be nice to group the symbols (in each +;;; type-group) by their home-package. +(defun sly-edit-uses (symbol) + "Lookup all the uses of SYMBOL." + (interactive (list (sly-read-symbol-name "Edit Uses of: "))) + (sly-xref--get-xrefs + sly-edit-uses-xrefs + symbol + (lambda (xrefs type symbol package) + (cond + ((and (sly-length= xrefs 1) ; one group + (sly-length= (cdar xrefs) 1)) ; one ref in group + (cl-destructuring-bind (_ (_ loc)) (cl-first xrefs) + (sly-push-definition-stack) + (sly--pop-to-source-location loc))) + (t + (sly-push-definition-stack) + (sly-xref--show-results xrefs type symbol package 'window)))))) + +(defun sly-analyze-xrefs (xrefs) + "Find common filenames in XREFS. +Return a list (SINGLE-LOCATION FILE-ALIST). +SINGLE-LOCATION is true if all xrefs point to the same location. +FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)." + (list (and xrefs + (let ((loc (sly-xref.location (car xrefs)))) + (and (sly-location-p loc) + (cl-every (lambda (x) (equal (sly-xref.location x) loc)) + (cdr xrefs))))) + (sly-alistify xrefs #'sly-xref-group #'equal))) + +(defun sly-xref-group (xref) + (cond ((sly-xref-has-location-p xref) + (sly-dcase (sly-location.buffer (sly-xref.location xref)) + ((:file filename) filename) + ((:buffer bufname) + (let ((buffer (get-buffer bufname))) + (if buffer + (format "%S" buffer) ; "#" + (format "%s (previously existing buffer)" bufname)))) + ((:buffer-and-file _buffer filename) filename) + ((:source-form _) "(S-Exp)") + ((:zip _zip entry) entry))) + (t + "(No location)"))) + +(defun sly-edit-definition-other-window (name) + "Like `sly-edit-definition' but switch to the other window." + (interactive (list (sly-read-symbol-name "Symbol: "))) + (sly-edit-definition name 'window)) + +(defun sly-edit-definition-other-frame (name) + "Like `sly-edit-definition' but switch to the other window." + (interactive (list (sly-read-symbol-name "Symbol: "))) + (sly-edit-definition name 'frame)) + + + +;;;;; first-change-hook + +(defun sly-first-change-hook () + "Notify Lisp that a source file's buffer has been modified." + ;; Be careful not to disturb anything! + ;; In particular if we muck up the match-data then query-replace + ;; breaks. -luke (26/Jul/2004) + (save-excursion + (save-match-data + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (sly-background-activities-enabled-p)) + (let ((filename (sly-to-lisp-filename (buffer-file-name)))) + (sly-eval-async `(slynk:buffer-first-change ,filename))))))) + +(defun sly-setup-first-change-hook () + (add-hook 'first-change-hook #'sly-first-change-hook nil t)) + +(add-hook 'sly-mode-hook 'sly-setup-first-change-hook) + + +;;;; Eval for Lisp + +(defun sly-eval-for-lisp (thread tag form-string) + (let ((ok nil) + (value nil) + (error nil) + (c (sly-connection))) + (unwind-protect + (condition-case err + (progn + (sly-check-eval-in-emacs-enabled) + (setq value (eval (read form-string) t)) + (sly-check-eval-in-emacs-result value) + (setq ok t)) + ((debug error) + (setq error err))) + (let ((result (cond (ok `(:ok ,value)) + (error `(:error ,(symbol-name (car error)) + . ,(mapcar #'prin1-to-string + (cdr error)))) + (t `(:abort))))) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,result) c))))) + +(defun sly-check-eval-in-emacs-result (x) + "Raise an error if X can't be marshaled." + (or (stringp x) + (memq x '(nil t)) + (integerp x) + (keywordp x) + (and (consp x) + (let ((l x)) + (while (consp l) + (sly-check-eval-in-emacs-result (car x)) + (setq l (cdr l))) + (sly-check-eval-in-emacs-result l))) + (error "Non-serializable return value: %S" x))) + +(defun sly-check-eval-in-emacs-enabled () + "Raise an error if `sly-enable-evaluate-in-emacs' isn't true." + (unless sly-enable-evaluate-in-emacs + (error (concat "sly-eval-in-emacs disabled for security." + "Set sly-enable-evaluate-in-emacs true to enable it.")))) + + +;;;; `ED' + +(defvar sly-ed-frame nil + "The frame used by `sly-ed'.") + +(defcustom sly-ed-use-dedicated-frame nil + "*When non-nil, `sly-ed' will create and reuse a dedicated frame." + :type 'boolean + :group 'sly-mode) + +(cl-defun sly-ed (what ) + "Edit WHAT. + +WHAT can be: + A filename (string), + A list (:filename FILENAME &key LINE COLUMN POSITION), + A function name (:function-name STRING) + nil. + +This is for use in the implementation of COMMON-LISP:ED." + (when sly-ed-use-dedicated-frame + (unless (and sly-ed-frame (frame-live-p sly-ed-frame)) + (setq sly-ed-frame (make-frame))) + (select-frame sly-ed-frame)) + (raise-frame) + (when what + (sly-dcase what + ((:filename file &key line column position bytep) + (find-file (sly-from-lisp-filename file)) + (when line (sly-goto-line line)) + (when column (move-to-column column)) + (when position + (goto-char (if bytep + (byte-to-position position) + position)))) + ((:function-name name) + (sly-edit-definition name))))) + +(defun sly-goto-line (line-number) + "Move to line LINE-NUMBER (1-based). +This is similar to `goto-line' but without pushing the mark and +the display stuff that we neither need nor want." + (cl-assert (= (buffer-size) (- (point-max) (point-min))) () + "sly-goto-line in narrowed buffer") + (goto-char (point-min)) + (forward-line (1- line-number))) + +(defun sly-remote-y-or-n-p (thread tag question) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,(sly-y-or-n-p question)))) + +(defun sly-read-from-minibuffer-for-slynk (thread tag prompt initial-value) + (let ((answer (condition-case nil + (sly-read-from-minibuffer prompt initial-value t) + (quit nil)))) + (sly-dispatch-event `(:emacs-return ,thread ,tag ,answer)))) + +;;;; Interactive evaluation. + +(defun sly-interactive-eval (string) + "Read and evaluate STRING and print value in minibuffer. + +A prefix argument(`C-u') inserts the result into the current +buffer. A negative prefix argument (`M--') will sends it to the +kill ring." + (interactive (list (sly-read-from-minibuffer "SLY Eval: "))) + (cl-case current-prefix-arg + ((nil) + (sly-eval-with-transcript `(slynk:interactive-eval ,string))) + ((-) + (sly-eval-save string)) + (t + (sly-eval-print string)))) + +(defvar sly-transcript-start-hook nil + "Hook run before start an evalution.") +(defvar sly-transcript-stop-hook nil + "Hook run after finishing a evalution.") + +(defun sly-display-eval-result (value) + ;; Use `message', not `sly-message' + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (end-of-line 1) + (if (or (< (1+ (point)) (point-max)) + (>= (- (point) (point-min)) (frame-width))) + (sly-show-description value (sly-current-package)) + (message "=> %s" value)))) + +(defun sly-eval-with-transcript (form) + "Eval FORM in Lisp. Display output, if any." + (run-hooks 'sly-transcript-start-hook) + (sly-rex () (form) + ((:ok value) + (run-hooks 'sly-transcript-stop-hook) + (sly-display-eval-result value)) + ((:abort condition) + (run-hooks 'sly-transcript-stop-hook) + (sly-message "Evaluation aborted on %s." condition)))) + +(defun sly-eval-print (string) + "Eval STRING in Lisp; insert any output and the result at point." + (sly-eval-async `(slynk:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (push-mark) + (let* ((start (point)) + (ppss (syntax-ppss)) + (string-or-comment-p (or (nth 3 ppss) (nth 4 ppss)))) + (insert output (if string-or-comment-p + "" + " => ") value) + (unless string-or-comment-p + (comment-region start (point) 1))))))) + +(defun sly-eval-save (string) + "Evaluate STRING in Lisp and save the result in the kill ring." + (sly-eval-async `(slynk:eval-and-grab-output ,string) + (lambda (result) + (cl-destructuring-bind (output value) result + (let ((string (concat output value))) + (kill-new string) + (sly-message "Evaluation finished; pushed result to kill ring.")))))) + +(defun sly-eval-describe (form) + "Evaluate FORM in Lisp and display the result in a new buffer." + (sly-eval-async form (sly-rcurry #'sly-show-description + (sly-current-package)))) + +(defvar sly-description-autofocus nil + "If non-nil select description windows on display.") + +(defun sly-show-description (string package) + ;; So we can have one description buffer open per connection. Useful + ;; for comparing the output of DISASSEMBLE across implementations. + ;; FIXME: could easily be achieved with M-x rename-buffer + (let ((bufname (sly-buffer-name :description))) + (sly-with-popup-buffer (bufname :package package + :connection t + :select sly-description-autofocus + :mode 'lisp-mode) + (sly-popup-buffer-mode) + (princ string) + (goto-char (point-min))))) + +(defun sly-last-expression () + (buffer-substring-no-properties + (save-excursion (backward-sexp) (point)) + (point))) + +(defun sly-eval-last-expression () + "Evaluate the expression preceding point." + (interactive) + (sly-interactive-eval (sly-last-expression))) + +(defun sly-eval-defun () + "Evaluate the current toplevel form. +Use `sly-re-evaluate-defvar' if the from starts with '(defvar'" + (interactive) + (let ((form (apply #'buffer-substring-no-properties + (sly-region-for-defun-at-point)))) + (cond ((string-match "^(defvar " form) + (sly-re-evaluate-defvar form)) + (t + (sly-interactive-eval form))))) + +(defun sly-eval-region (start end) + "Evaluate region." + (interactive "r") + (sly-eval-with-transcript + `(slynk:interactive-eval-region + ,(buffer-substring-no-properties start end)))) + +(defun sly-pprint-eval-region (start end) + "Evaluate region; pprint the value in a buffer." + (interactive "r") + (sly-eval-describe + `(slynk:pprint-eval + ,(buffer-substring-no-properties start end)))) + +(defun sly-eval-buffer () + "Evaluate the current buffer. +The value is printed in the echo area." + (interactive) + (sly-eval-region (point-min) (point-max))) + +(defun sly-re-evaluate-defvar (form) + "Force the re-evaluaton of the defvar form before point. + +First make the variable unbound, then evaluate the entire form." + (interactive (list (sly-last-expression))) + (sly-eval-with-transcript `(slynk:re-evaluate-defvar ,form))) + +(defun sly-pprint-eval-last-expression () + "Evaluate the form before point; pprint the value in a buffer." + (interactive) + (sly-eval-describe `(slynk:pprint-eval ,(sly-last-expression)))) + +(defun sly-eval-print-last-expression (string) + "Evaluate sexp before point; print value into the current buffer" + (interactive (list (sly-last-expression))) + (insert "\n") + (sly-eval-print string)) + +;;;; Edit Lisp value +;;; +(defun sly-edit-value (form-string) + "\\\ +Edit the value of a setf'able form in a new buffer. +The value is inserted into a temporary buffer for editing and then set +in Lisp when committed with \\[sly-edit-value-commit]." + (interactive + (list (sly-read-from-minibuffer "Edit value (evaluated): " + (sly-sexp-at-point)))) + (sly-eval-async `(slynk:value-for-editing ,form-string) + (let ((form-string form-string) + (package (sly-current-package))) + (lambda (result) + (sly-edit-value-callback form-string result + package))))) + +(make-variable-buffer-local + (defvar sly-edit-form-string nil + "The form being edited by `sly-edit-value'.")) + +(define-minor-mode sly-edit-value-mode + "Mode for editing a Lisp value." + nil + " Edit-Value" + '(("\C-c\C-c" . sly-edit-value-commit))) + +(defun sly-edit-value-callback (form-string current-value package) + (let* ((name (generate-new-buffer-name (format "*Edit %s*" form-string))) + (buffer (sly-with-popup-buffer (name :package package + :connection t + :select t + :mode 'lisp-mode) + (sly-mode 1) + (sly-edit-value-mode 1) + (setq sly-edit-form-string form-string) + (insert current-value) + (current-buffer)))) + (with-current-buffer buffer + (setq buffer-read-only nil) + (sly-message "Type C-c C-c when done")))) + +(defun sly-edit-value-commit () + "Commit the edited value to the Lisp image. +\\(See `sly-edit-value'.)" + (interactive) + (if (null sly-edit-form-string) + (error "Not editing a value.") + (let ((value (buffer-substring-no-properties (point-min) (point-max)))) + (let ((buffer (current-buffer))) + (sly-eval-async `(slynk:commit-edited-value ,sly-edit-form-string + ,value) + (lambda (_) + (with-current-buffer buffer + (quit-window t)))))))) + +;;;; Tracing + +(defun sly-untrace-all () + "Untrace all functions." + (interactive) + (sly-eval `(slynk:untrace-all))) + +(defun sly-toggle-trace-fdefinition (spec) + "Toggle trace." + (interactive (list (sly-read-from-minibuffer + "(Un)trace: " (sly-symbol-at-point)))) + (sly-message "%s" (sly-eval `(slynk:slynk-toggle-trace ,spec)))) + + + +(defun sly-disassemble-symbol (symbol-name) + "Display the disassembly for SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "Disassemble: "))) + (sly-eval-describe `(slynk:disassemble-form ,(concat "'" symbol-name)))) + +(defun sly-undefine-function (symbol-name) + "Unbind the function slot of SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "fmakunbound: " t))) + (sly-eval-async `(slynk:undefine-function ,symbol-name) + (lambda (result) (sly-message "%s" result)))) + +(defun sly-remove-method (name qualifiers specializers) + "Remove a method from generic function named NAME. +The method removed is identified by QUALIFIERS and SPECIALIZERS." + (interactive (sly--read-method + "[sly] Remove method from which generic function: " + "[sly] Remove which method from %s")) + (sly-eval `(slynk:remove-method-by-name ,name + ',qualifiers + ',specializers)) + (sly-message "Method removed")) + +(defun sly-unintern-symbol (symbol-name package) + "Unintern the symbol given with SYMBOL-NAME PACKAGE." + (interactive (list (sly-read-symbol-name "Unintern symbol: " t) + (sly-read-package-name "from package: " + (sly-current-package)))) + (sly-eval-async `(slynk:unintern-symbol ,symbol-name ,package) + (lambda (result) (sly-message "%s" result)))) + +(defun sly-delete-package (package-name) + "Delete the package with name PACKAGE-NAME." + (interactive (list (sly-read-package-name "Delete package: " + (sly-current-package)))) + (sly-eval-async `(cl:delete-package + (slynk::guess-package ,package-name)))) + +(defun sly-load-file (filename) + "Load the Lisp file FILENAME." + (interactive (list + (read-file-name "[sly] Load file: " nil nil + nil (if (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((lisp-filename (sly-to-lisp-filename (expand-file-name filename)))) + (sly-eval-with-transcript `(slynk:load-file ,lisp-filename)))) + +(defvar sly-change-directory-hooks nil + "Hook run by `sly-change-directory'. +The functions are called with the new (absolute) directory.") + +(defun sly-change-directory (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever slynk:set-default-directory returns." + (let ((dir (expand-file-name directory))) + (prog1 (sly-eval `(slynk:set-default-directory + (slynk-backend:filename-to-pathname + ,(sly-to-lisp-filename dir)))) + (sly-with-connection-buffer nil (cd-absolute dir)) + (run-hook-with-args 'sly-change-directory-hooks dir)))) + +(defun sly-cd (directory) + "Make DIRECTORY become Lisp's current directory. +Return whatever slynk:set-default-directory returns." + (interactive (list (read-directory-name "[sly] Directory: " nil nil t))) + (sly-message "default-directory: %s" (sly-change-directory directory))) + +(defun sly-pwd () + "Show Lisp's default directory." + (interactive) + (sly-message "Directory %s" (sly-eval `(slynk:default-directory)))) + + +;;;; Documentation + +(defvar sly-documentation-lookup-function + 'sly-hyperspec-lookup) + +(defun sly-documentation-lookup () + "Generalized documentation lookup. Defaults to hyperspec lookup." + (interactive) + (call-interactively sly-documentation-lookup-function)) + +;;;###autoload +(defun sly-hyperspec-lookup (symbol-name) + "A wrapper for `hyperspec-lookup'" + (interactive (list (common-lisp-hyperspec-read-symbol-name + (sly-symbol-at-point)))) + (hyperspec-lookup symbol-name)) + +(defun sly-describe-symbol (symbol-name) + "Describe the symbol at point." + (interactive (list (sly-read-symbol-name "Describe symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe `(slynk:describe-symbol ,symbol-name))) + +(defun sly-documentation (symbol-name) + "Display function- or symbol-documentation for SYMBOL-NAME." + (interactive (list (sly-read-symbol-name "Documentation for symbol: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe + `(slynk:documentation-symbol ,symbol-name))) + +(defun sly-describe-function (symbol-name) + (interactive (list (sly-read-symbol-name "Describe symbol's function: "))) + (when (not symbol-name) + (error "No symbol given")) + (sly-eval-describe `(slynk:describe-function ,symbol-name))) + +(defface sly-apropos-symbol + '((t (:inherit sly-part-button-face))) + "Face for the symbol name in Apropos output." + :group 'sly) + +(defface sly-apropos-label + '((t (:inherit italic))) + "Face for label (`Function', `Variable' ...) in Apropos output." + :group 'sly) + +(defun sly-apropos-summary (string case-sensitive-p package only-external-p) + "Return a short description for the performed apropos search." + (concat (if case-sensitive-p "Case-sensitive " "") + "Apropos for " + (format "%S" string) + (if package (format " in package %S" package) "") + (if only-external-p " (external symbols only)" ""))) + +(defun sly-apropos (string &optional only-external-p package + case-sensitive-p) + "Show all bound symbols whose names match STRING. With prefix +arg, you're interactively asked for parameters of the search. +With M-- (negative) prefix arg, prompt for package only. " + (interactive + (cond ((eq '- current-prefix-arg) + (list (sly-read-from-minibuffer "Apropos external symbols: ") + t + (sly-read-package-name "Package (blank for all): " + nil 'allow-blank) + nil)) + (current-prefix-arg + (list (sly-read-from-minibuffer "Apropos: ") + (sly-y-or-n-p "External symbols only? ") + (sly-read-package-name "Package (blank for all): " + nil 'allow-blank) + (sly-y-or-n-p "Case-sensitive? "))) + (t + (list (sly-read-from-minibuffer "Apropos external symbols: ") t nil nil)))) + (sly-eval-async + `(slynk-apropos:apropos-list-for-emacs ,string ,only-external-p + ,case-sensitive-p ',package) + (sly-rcurry #'sly-show-apropos string package + (sly-apropos-summary string case-sensitive-p + package only-external-p)))) + +(defun sly-apropos-all () + "Shortcut for (sly-apropos nil nil)" + (interactive) + (sly-apropos (sly-read-from-minibuffer "Apropos all symbols: ") nil nil)) + +(defun sly-apropos-package (package &optional internal) + "Show apropos listing for symbols in PACKAGE. +With prefix argument include internal symbols." + (interactive (list (let ((pkg (sly-read-package-name "Package: "))) + (if (string= pkg "") (sly-current-package) pkg)) + current-prefix-arg)) + (sly-apropos "" (not internal) package)) + +(defvar sly-apropos-mode-map + (let ((map (make-sparse-keymap))) + map)) + +(define-derived-mode sly-apropos-mode apropos-mode "SLY-Apropos" + "SLY Apropos Mode + +TODO" + (sly-mode)) + +(defun sly-show-apropos (plists string package summary) + (cond ((null plists) + (sly-message "No apropos matches for %S" string)) + (t + (sly-with-popup-buffer ((sly-buffer-name :apropos + :connection t) + :package package :connection t + :mode 'sly-apropos-mode) + (if (boundp 'header-line-format) + (setq header-line-format summary) + (insert summary "\n\n")) + (sly-set-truncate-lines) + (sly-print-apropos plists (not package)) + (set-syntax-table lisp-mode-syntax-table) + (goto-char (point-min)))))) + +(define-button-type 'sly-apropos-symbol :supertype 'sly-part + 'face nil + 'action 'sly-button-goto-source ;default action + 'sly-button-inspect + #'(lambda (name _type) + (sly-inspect (format "(quote %s)" name))) + 'sly-button-goto-source + #'(lambda (name _type) + (sly-edit-definition name 'window)) + 'sly-button-describe + #'(lambda (name _type) + (sly-eval-describe `(slynk:describe-symbol ,name)))) + +(defun sly--package-designator-prefix (designator) + (unless (listp designator) + (error "unknown designator type")) + (concat (cadr designator) + (if (cl-caddr designator) ":" "::"))) + +(defun sly-apropos-designator-string (designator) + (concat (sly--package-designator-prefix designator) + (car designator))) + +(defun sly-apropos-insert-symbol (designator item bounds package-designator-searched-p) + (let ((label (sly-apropos-designator-string designator))) + (setq label + (sly--make-text-button label nil + 'face 'sly-apropos-symbol + 'part-args (list item nil) + 'part-label "Symbol" + :type 'sly-apropos-symbol)) + (cl-loop + with offset = (if package-designator-searched-p + 0 + (length (sly--package-designator-prefix designator))) + for bound in bounds + for (start end) = (if (listp bound) bound (list bound (1+ bound))) + do + (put-text-property (+ start offset) (+ end offset) 'face 'highlight label) + finally (insert label)))) + +(defun sly-print-apropos (plists package-designator-searched-p) + (cl-loop + for plist in plists + for designator = (plist-get plist :designator) + for item = (substring-no-properties + (sly-apropos-designator-string designator)) + do + (sly-apropos-insert-symbol designator item (plist-get plist :bounds) package-designator-searched-p) + (terpri) + (cl-loop for (prop value) on plist by #'cddr + for start = (point) + unless (memq prop '(:designator + :package + :bounds)) + do + (let ((namespace (upcase-initials + (replace-regexp-in-string + "-" " " (substring (symbol-name prop) 1))))) + (princ " ") + (insert (propertize namespace + 'face 'sly-apropos-label)) + (princ ": ") + (princ (cond ((and value + (not (eq value :not-documented))) + value) + (t + "(not documented)"))) + (add-text-properties + start (point) + (list 'action 'sly-button-describe + 'sly-button-describe + #'(lambda (name type) + (sly-eval-describe `(slynk:describe-definition-for-emacs ,name + ,type))) + 'part-args (list item prop) + 'button t 'apropos-label namespace)) + (terpri))))) + +(defun sly-apropos-describe (name type) + (sly-eval-describe `(slynk:describe-definition-for-emacs ,name ,type))) + +(require 'info) +(defun sly-info--file () + (or (cl-some (lambda (subdir) + (cl-flet ((existing-file + (name) (let* ((path (expand-file-name subdir sly-path)) + (probe (expand-file-name name path))) + (and (file-exists-p probe) probe)))) + (or (existing-file "sly.info") + (existing-file "sly.info.gz")))) + (append '("doc" ".") Info-directory-list)) + (sly-error + "No sly.info, run `make -C doc sly.info' from a SLY git checkout"))) + +(require 'info) + +(defvar sly-info--cached-node-names nil) + +(defun sly-info--node-names (file) + (or sly-info--cached-node-names + (setq sly-info--cached-node-names + (with-temp-buffer + (info file (current-buffer)) + (ignore-errors + (Info-build-node-completions)))))) + +;;;###autoload +(defun sly-info (file &optional node) + "Read SLY manual" + (interactive + (let ((file (sly-info--file))) + (list file + (completing-read "Manual node? (`Top' to read the whole manual): " + (remove '("*") (sly-info--node-names file)) + nil t)))) + (info (if node (format "(%s)%s" file node) file))) + + +;;;; XREF: cross-referencing + +(defvar sly-xref-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'sly-xref-goto) + (define-key map (kbd "SPC") 'sly-xref-show) + (define-key map (kbd "n") 'sly-xref-next-line) + (define-key map (kbd "p") 'sly-xref-prev-line) + (define-key map (kbd ".") 'sly-xref-next-line) + (define-key map (kbd ",") 'sly-xref-prev-line) + (define-key map (kbd "C-c C-c") 'sly-recompile-xref) + (define-key map (kbd "C-c C-k") 'sly-recompile-all-xrefs) + + (define-key map (kbd "q") 'quit-window) + (set-keymap-parent map button-buffer-map) + + map)) + +(define-derived-mode sly-xref-mode lisp-mode "Xref" + "sly-xref-mode: Major mode for cross-referencing. +\\\ +The most important commands: +\\[sly-xref-show] - Display referenced source and keep xref window. +\\[sly-xref-goto] - Jump to referenced source and dismiss xref window. + +\\{sly-xref-mode-map}" + (setq font-lock-defaults nil) + (setq delayed-mode-hooks nil) + (setq buffer-read-only t) + (sly-mode)) + +(defun sly-next-line/not-add-newlines () + (interactive) + (let ((next-line-add-newlines nil)) + (forward-line 1))) + + +;;;;; XREF results buffer and window management + +(cl-defmacro sly-with-xref-buffer ((_xref-type _symbol &optional package) + &body body) + "Execute BODY in a xref buffer, then show that buffer." + (declare (indent 1)) + `(sly-with-popup-buffer ((sly-buffer-name :xref + :connection t) + :package ,package + :connection t + :select t + :mode 'sly-xref-mode) + (sly-set-truncate-lines) + ,@body)) + +;; TODO: Have this button support more options, not just "show source" +;; and "goto-source" +(define-button-type 'sly-xref :supertype 'sly-part + 'action 'sly-button-goto-source ;default action + 'mouse-action 'sly-button-goto-source ;default action + 'sly-button-show-source #'(lambda (location) + (sly-xref--show-location location)) + 'sly-button-goto-source #'(lambda (location) + (sly--pop-to-source-location location 'sly-xref))) + +(defun sly-xref-button (label location) + (sly--make-text-button label nil + :type 'sly-xref + 'part-args (list location) + 'part-label "Location")) + +(defun sly-insert-xrefs (xref-alist) + "Insert XREF-ALIST in the current-buffer. +XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...). +GROUP and LABEL are for decoration purposes. LOCATION is a +source-location." + (cl-loop for (group . refs) in xref-alist do + (sly-insert-propertized '(face bold) group "\n") + (cl-loop for (label location) in refs + for start = (point) + do + (insert + " " + (sly-xref-button (sly-one-line-ify label) location) + "\n") + (add-text-properties start (point) (list 'sly-location location)))) + ;; Remove the final newline to prevent accidental window-scrolling + (backward-delete-char 1)) + +(defun sly-xref-next-line (arg) + (interactive "p") + (let ((button (forward-button arg))) + (when button (sly-button-show-source button)))) + +(defun sly-xref-prev-line (arg) + (interactive "p") + (sly-xref-next-line (- arg))) + +(defun sly-xref--show-location (loc) + (cl-ecase (car loc) + (:location (sly--display-source-location loc)) + (:error (sly-message "%s" (cadr loc))) + ((nil)))) + +(defun sly-xref--show-results (xrefs _type symbol package &optional method) + "Maybe show a buffer listing the cross references XREFS. +METHOD is used to set `sly-xref--popup-method', which see." + (cond ((null xrefs) + (sly-message "No references found for %s." symbol) + nil) + (t + (sly-with-xref-buffer (_type _symbol package) + (sly-insert-xrefs xrefs) + (setq sly-xref--popup-method method) + (goto-char (point-min)) + (current-buffer))))) + + +;;;;; XREF commands + +(defun sly-who-calls (symbol) + "Show all known callers of the function SYMBOL. +This is implemented with special compiler support, see `sly-list-callers' for a +portable alternative." + (interactive (list (sly-read-symbol-name "Who calls: " t))) + (sly-xref :calls symbol)) + +(defun sly-calls-who (symbol) + "Show all known functions called by the function SYMBOL. +This is implemented with special compiler support and may not be supported by +all implementations. +See `sly-list-callees' for a portable alternative." + (interactive (list (sly-read-symbol-name "Who calls: " t))) + (sly-xref :calls-who symbol)) + +(defun sly-who-references (symbol) + "Show all known referrers of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who references: " t))) + (sly-xref :references symbol)) + +(defun sly-who-binds (symbol) + "Show all known binders of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who binds: " t))) + (sly-xref :binds symbol)) + +(defun sly-who-sets (symbol) + "Show all known setters of the global variable SYMBOL." + (interactive (list (sly-read-symbol-name "Who sets: " t))) + (sly-xref :sets symbol)) + +(defun sly-who-macroexpands (symbol) + "Show all known expanders of the macro SYMBOL." + (interactive (list (sly-read-symbol-name "Who macroexpands: " t))) + (sly-xref :macroexpands symbol)) + +(defun sly-who-specializes (symbol) + "Show all known methods specialized on class SYMBOL." + (interactive (list (sly-read-symbol-name "Who specializes: " t))) + (sly-xref :specializes symbol)) + +(defun sly-list-callers (symbol-name) + "List the callers of SYMBOL-NAME in a xref window. +See `sly-who-calls' for an implementation-specific alternative." + (interactive (list (sly-read-symbol-name "List callers: "))) + (sly-xref :callers symbol-name)) + +(defun sly-list-callees (symbol-name) + "List the callees of SYMBOL-NAME in a xref window. +See `sly-calls-who' for an implementation-specific alternative." + (interactive (list (sly-read-symbol-name "List callees: "))) + (sly-xref :callees symbol-name)) + +(defun sly-xref (type symbol &optional continuation) + "Make an XREF request to Lisp." + (sly-eval-async + `(slynk:xref ',type ',symbol) + (sly-rcurry (lambda (result type symbol package cont) + (and (sly-xref-implemented-p type result) + (let* ((file-alist (cadr (sly-analyze-xrefs result)))) + (funcall (or cont 'sly-xref--show-results) + file-alist type symbol package)))) + type + symbol + (sly-current-package) + continuation))) + +(defun sly-xref-implemented-p (type xrefs) + "Tell if xref TYPE is available according to XREFS." + (cond ((eq xrefs :not-implemented) + (sly-display-oneliner "%s is not implemented yet on %s." + (sly-xref-type type) + (sly-lisp-implementation-name)) + nil) + (t t))) + +(defun sly-xref-type (type) + "Return a human readable version of xref TYPE." + (format "who-%s" (sly-cl-symbol-name type))) + +(defun sly-xref--get-xrefs (types symbol &optional continuation) + "Make multiple XREF requests at once." + (sly-eval-async + `(slynk:xrefs ',types ',symbol) + #'(lambda (result) + (funcall (or continuation + #'sly-xref--show-results) + (cl-loop for (key . val) in result + collect (cons (sly-xref-type key) val)) + types symbol (sly-current-package))))) + + +;;;;; XREF navigation + +(defun sly-xref-location-at-point () + (save-excursion + ;; When the end of the last line is at (point-max) we can't find + ;; the text property there. Going to bol avoids this problem. + (beginning-of-line 1) + (or (get-text-property (point) 'sly-location) + (error "No reference at point.")))) + +(defun sly-xref-dspec-at-point () + (save-excursion + (beginning-of-line 1) + (with-syntax-table lisp-mode-syntax-table + (forward-sexp) ; skip initial whitespaces + (backward-sexp) + (sly-sexp-at-point)))) + +(defun sly-all-xrefs () + (let ((xrefs nil)) + (save-excursion + (goto-char (point-min)) + (while (zerop (forward-line 1)) + (sly--when-let (loc (get-text-property (point) 'sly-location)) + (let* ((dspec (sly-xref-dspec-at-point)) + (xref (make-sly-xref :dspec dspec :location loc))) + (push xref xrefs))))) + (nreverse xrefs))) + +(defun sly-xref-goto () + "Goto the cross-referenced location at point." + (interactive) + (sly--pop-to-source-location (sly-xref-location-at-point) 'sly-xref)) + +(defun sly-xref-show () + "Display the xref at point in the other window." + (interactive) + (sly--display-source-location (sly-xref-location-at-point))) + +(defun sly-search-property (prop &optional backward prop-value-fn) + "Search the next text range where PROP is non-nil. +Return the value of PROP. +If BACKWARD is non-nil, search backward. +If PROP-VALUE-FN is non-nil use it to extract PROP's value." + (let ((next-candidate (if backward + #'previous-single-char-property-change + #'next-single-char-property-change)) + (prop-value-fn (or prop-value-fn + (lambda () + (get-text-property (point) prop)))) + (start (point)) + (prop-value)) + (while (progn + (goto-char (funcall next-candidate (point) prop)) + (not (or (setq prop-value (funcall prop-value-fn)) + (eobp) + (bobp))))) + (cond (prop-value) + (t (goto-char start) nil)))) + +(defun sly-recompile-xref (&optional raw-prefix-arg) + "Recompile definition at point. +Uses prefix arguments like `sly-compile-defun'." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (let ((location (sly-xref-location-at-point)) + (dspec (sly-xref-dspec-at-point))) + (sly-recompile-locations + (list location) + (sly-rcurry #'sly-xref-recompilation-cont + (list dspec) (current-buffer)))))) + +(defun sly-recompile-all-xrefs (&optional raw-prefix-arg) + "Recompile all definitions. +Uses prefix arguments like `sly-compile-defun'." + (interactive "P") + (let ((sly-compilation-policy (sly-compute-policy raw-prefix-arg))) + (let ((dspecs) (locations)) + (dolist (xref (sly-all-xrefs)) + (when (sly-xref-has-location-p xref) + (push (sly-xref.dspec xref) dspecs) + (push (sly-xref.location xref) locations))) + (sly-recompile-locations + locations + (sly-rcurry #'sly-xref-recompilation-cont + dspecs (current-buffer)))))) + +(defun sly-xref-recompilation-cont (results dspecs buffer) + ;; Extreme long-windedness to insert status of recompilation; + ;; sometimes Elisp resembles more of an Ewwlisp. + + ;; FIXME: Should probably throw out the whole recompilation cruft + ;; anyway. -- helmut + ;; TODO: next iteration of fixme cleanup this is going in a contrib -- jt + (with-current-buffer buffer + (sly-compilation-finished (sly-aggregate-compilation-results results) + nil) + (save-excursion + (sly-xref-insert-recompilation-flags + dspecs (cl-loop for r in results collect + (or (sly-compilation-result.successp r) + (and (sly-compilation-result.notes r) + :complained))))))) + +(defun sly-aggregate-compilation-results (results) + `(:compilation-result + ,(cl-reduce #'append (mapcar #'sly-compilation-result.notes results)) + ,(cl-every #'sly-compilation-result.successp results) + ,(cl-reduce #'+ (mapcar #'sly-compilation-result.duration results)))) + +(defun sly-xref-insert-recompilation-flags (dspecs compilation-results) + (let* ((buffer-read-only nil) + (max-column (sly-column-max))) + (goto-char (point-min)) + (cl-loop for dspec in dspecs + for result in compilation-results + do (save-excursion + (cl-loop for dspec2 = (progn (search-forward dspec) + (sly-xref-dspec-at-point)) + until (equal dspec2 dspec)) + (end-of-line) ; skip old status information. + (insert-char ?\ (1+ (- max-column (current-column)))) + (insert (format "[%s]" + (cl-case result + ((t) :success) + ((nil) :failure) + (t result)))))))) + + +;;;; Macroexpansion + +(defvar sly-macroexpansion-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "g") 'sly-macroexpand-again) + (define-key map (kbd "a") 'sly-macroexpand-all-inplace) + (define-key map (kbd "q") 'quit-window) + (define-key map [remap sly-macroexpand-1] 'sly-macroexpand-1-inplace) + (define-key map [remap sly-macroexpand-all] 'sly-macroexpand-all-inplace) + (define-key map [remap sly-compiler-macroexpand-1] 'sly-compiler-macroexpand-1-inplace) + (define-key map [remap sly-expand-1] 'sly-expand-1-inplace) + (define-key map [remap undo] 'sly-macroexpand-undo) + map)) + +(define-minor-mode sly-macroexpansion-minor-mode + "SLY mode for macroexpansion" + nil + " Macroexpand" + nil + (read-only-mode 1)) + +(defun sly-macroexpand-undo (&optional arg) + (interactive) + ;; Emacs 22.x introduced `undo-only' which + ;; works by binding `undo-no-redo' to t. We do + ;; it this way so we don't break prior Emacs + ;; versions. + (cl-macrolet ((undo-only (arg) `(let ((undo-no-redo t)) (undo ,arg)))) + (let ((inhibit-read-only t)) + (when (fboundp 'sly-remove-edits) + (sly-remove-edits (point-min) (point-max))) + (undo-only arg)))) + +(defvar sly-eval-macroexpand-expression nil + "Specifies the last macroexpansion preformed. +This variable specifies both what was expanded and how.") + +(defun sly-eval-macroexpand (expander &optional string) + (let ((string (or string + (sly-sexp-at-point 'interactive)))) + (setq sly-eval-macroexpand-expression `(,expander ,string)) + (sly-eval-async sly-eval-macroexpand-expression + #'sly-initialize-macroexpansion-buffer))) + +(defun sly-macroexpand-again () + "Reperform the last macroexpansion." + (interactive) + (sly-eval-async sly-eval-macroexpand-expression + (sly-rcurry #'sly-initialize-macroexpansion-buffer + (current-buffer)))) + +(defun sly-initialize-macroexpansion-buffer (expansion &optional buffer) + (pop-to-buffer (or buffer (sly-create-macroexpansion-buffer))) + (setq buffer-undo-list nil) ; Get rid of undo information from + ; previous expansions. + (let ((inhibit-read-only t) + (buffer-undo-list t)) ; Make the initial insertion not be undoable. + (erase-buffer) + (insert expansion) + (goto-char (point-min)) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))))) + +(defun sly-create-macroexpansion-buffer () + (let ((name (sly-buffer-name :macroexpansion))) + (sly-with-popup-buffer (name :package t :connection t + :mode 'lisp-mode) + (sly-macroexpansion-minor-mode 1) + (setq font-lock-keywords-case-fold-search t) + (current-buffer)))) + +(defun sly-eval-macroexpand-inplace (expander) + "Substitute the sexp at point with its macroexpansion. + +NB: Does not affect sly-eval-macroexpand-expression" + (interactive) + (let* ((bounds (sly-bounds-of-sexp-at-point 'interactive))) + (let* ((start (copy-marker (car bounds))) + (end (copy-marker (cdr bounds))) + (point (point)) + (buffer (current-buffer))) + (sly-eval-async + `(,expander ,(buffer-substring-no-properties start end)) + (lambda (expansion) + (with-current-buffer buffer + (let ((buffer-read-only nil)) + (when (fboundp 'sly-remove-edits) + (sly-remove-edits (point-min) (point-max))) + (goto-char start) + (delete-region start end) + (sly-insert-indented expansion) + (goto-char point)))))))) + +(defun sly-macroexpand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) + +(defun sly-macroexpand-1-inplace (&optional repeatedly) + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly 'slynk:slynk-macroexpand 'slynk:slynk-macroexpand-1))) + +(defun sly-macroexpand-all (&optional just-one) + "Display the recursively macro expanded sexp at point. +With optional JUST-ONE prefix arg, use CL:MACROEXPAND-1." + (interactive "P") + (sly-eval-macroexpand (if just-one + 'slynk:slynk-macroexpand-1 + 'slynk:slynk-macroexpand-all))) + +(defun sly-macroexpand-all-inplace () + "Display the recursively macro expanded sexp at point." + (interactive) + (sly-eval-macroexpand-inplace 'slynk:slynk-macroexpand-all)) + +(defun sly-compiler-macroexpand-1 (&optional repeatedly) + "Display the compiler-macro expansion of sexp at point." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly + 'slynk:slynk-compiler-macroexpand + 'slynk:slynk-compiler-macroexpand-1))) + +(defun sly-compiler-macroexpand-1-inplace (&optional repeatedly) + "Display the compiler-macro expansion of sexp at point." + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly + 'slynk:slynk-compiler-macroexpand + 'slynk:slynk-compiler-macroexpand-1))) + +(defun sly-expand-1 (&optional repeatedly) + "Display the macro expansion of the form at point. + +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND. + +Contrary to `sly-macroexpand-1', if the form denotes a compiler +macro, SLYNK-BACKEND:COMPILER-MACROEXPAND or +SLYNK-BACKEND:COMPILER-MACROEXPAND-1 are used instead." + (interactive "P") + (sly-eval-macroexpand + (if repeatedly + 'slynk:slynk-expand + 'slynk:slynk-expand-1))) + +(defun sly-expand-1-inplace (&optional repeatedly) + "Display the macro expansion of the form at point. +The form is expanded with CL:MACROEXPAND-1 or, if a prefix +argument is given, with CL:MACROEXPAND." + (interactive "P") + (sly-eval-macroexpand-inplace + (if repeatedly + 'slynk:slynk-expand + 'slynk:slynk-expand-1))) + +(defun sly-format-string-expand (&optional string) + "Expand the format-string at point and display it. +With prefix arg, or if no string at point, prompt the user for a +string to expand. +" + (interactive (list (or (and (not current-prefix-arg) + (sly-string-at-point)) + (sly-read-from-minibuffer "Expand format: " + (sly-string-at-point))))) + (sly-eval-macroexpand 'slynk:slynk-format-string-expand + string)) + + +;;;; Subprocess control + +(defun sly-interrupt () + "Interrupt Lisp." + (interactive) + (cond ((sly-use-sigint-for-interrupt) (sly-send-sigint)) + (t (sly-dispatch-event `(:emacs-interrupt ,sly-current-thread))))) + +(defun sly-quit () + (error "Not implemented properly. Use `sly-interrupt' instead.")) + +(defun sly-quit-lisp (&optional kill interactive) + "Quit lisp, kill the inferior process and associated buffers." + (interactive (list current-prefix-arg t)) + (let ((connection (if interactive + (sly-prompt-for-connection "Connection to quit: ") + (sly-current-connection)))) + (sly-quit-lisp-internal connection 'sly-quit-sentinel kill))) + +(defun sly-quit-lisp-internal (connection sentinel kill) + "Kill SLY socket connection CONNECTION. +Do this by evaluating (SLYNK:QUIT-LISP) in it, and don't wait for +it to reply as usual with other evaluations. If it's non-nil, +setup SENTINEL to run on CONNECTION when it finishes dying. If +KILL is t, and there is such a thing, also kill the inferior lisp +process associated with CONNECTION." + (let ((sly-dispatching-connection connection)) + (sly-eval-async '(slynk:quit-lisp)) + (set-process-filter connection nil) + (let ((attempt 0) + (dying-p nil)) + (set-process-sentinel + connection + (lambda (connection status) + (setq dying-p t) + (sly-message "Connection %s is dying (%s)" connection status) + (let ((inf-process (sly-inferior-process connection))) + (cond ((and kill + inf-process + (not (memq (process-status inf-process) '(exit signal)))) + (sly-message "Quitting %s: also killing the inferior process %s" + connection inf-process) + (kill-process inf-process)) + ((and kill + inf-process) + (sly-message "Quitting %s: inferior process was already dead" + connection + inf-process)) + ((and + kill + (not inf-process)) + (sly-message "Quitting %s: No inferior process to kill!" + connection + inf-process)))) + (when sentinel + (funcall sentinel connection status)))) + (sly-message + "Waiting for connection %s to die by itself..." connection) + (while (and (< (cl-incf attempt) 30) + (not dying-p)) + (sleep-for 0.1)) + (unless dying-p + (sly-message + "Connection %s didn't die by itself. Killing it." connection) + (delete-process connection))))) + +(defun sly-quit-sentinel (process _message) + (cl-assert (process-status process) 'closed) + (let* ((inferior (sly-inferior-process process)) + (inferior-buffer (if inferior (process-buffer inferior)))) + (when inferior (delete-process inferior)) + (when inferior-buffer (kill-buffer inferior-buffer)) + (sly-net-close process "Quitting lisp") + (sly-message "Connection closed."))) + + +;;;; Debugger (SLY-DB) + +(defvar sly-db-hook nil + "Hook run on entry to the debugger.") + +(defcustom sly-db-initial-restart-limit 6 + "Maximum number of restarts to display initially." + :group 'sly-debugger + :type 'integer) + + +;;;;; Local variables in the debugger buffer + +;; Small helper. +(defun sly-make-variables-buffer-local (&rest variables) + (mapcar #'make-variable-buffer-local variables)) + +(sly-make-variables-buffer-local + (defvar sly-db-condition nil + "A list (DESCRIPTION TYPE) describing the condition being debugged.") + + (defvar sly-db-restarts nil + "List of (NAME DESCRIPTION) for each available restart.") + + (defvar sly-db-level nil + "Current debug level (recursion depth) displayed in buffer.") + + (defvar sly-db-backtrace-start-marker nil + "Marker placed at the first frame of the backtrace.") + + (defvar sly-db-restart-list-start-marker nil + "Marker placed at the first restart in the restart list.") + + (defvar sly-db-continuations nil + "List of ids for pending continuation.")) + +;;;;; SLY-DB macros + +;; some macros that we need to define before the first use + +(defmacro sly-db-in-face (name string) + "Return STRING propertised with face sly-db-NAME-face." + (declare (indent 1)) + (let ((facename (intern (format "sly-db-%s-face" (symbol-name name)))) + (var (cl-gensym "string"))) + `(let ((,var ,string)) + (sly-add-face ',facename ,var) + ,var))) + + +;;;;; sly-db-mode + +(defvar sly-db-mode-syntax-table + (let ((table (copy-syntax-table lisp-mode-syntax-table))) + ;; We give < and > parenthesis syntax, so that #< ... > is treated + ;; as a balanced expression. This enables autodoc-mode to match + ;; # actual arguments in the backtraces with formal + ;; arguments of the function. (For Lisp mode, this is not + ;; desirable, since we do not wish to get a mismatched paren + ;; highlighted everytime we type < or >.) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + table) + "Syntax table for SLY-DB mode.") + +(defvar sly-db-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "n" 'sly-db-down) + (define-key map "p" 'sly-db-up) + (define-key map "\M-n" 'sly-db-details-down) + (define-key map "\M-p" 'sly-db-details-up) + (define-key map "<" 'sly-db-beginning-of-backtrace) + (define-key map ">" 'sly-db-end-of-backtrace) + + (define-key map "a" 'sly-db-abort) + (define-key map "q" 'sly-db-abort) + (define-key map "c" 'sly-db-continue) + (define-key map "A" 'sly-db-break-with-system-debugger) + (define-key map "B" 'sly-db-break-with-default-debugger) + (define-key map "P" 'sly-db-print-condition) + (define-key map "I" 'sly-db-invoke-restart-by-name) + (define-key map "C" 'sly-db-inspect-condition) + (define-key map ":" 'sly-interactive-eval) + (define-key map "Q" 'sly-db-quit) + + (set-keymap-parent map button-buffer-map) + map)) + +(define-derived-mode sly-db-mode fundamental-mode "sly-db" + "Superior lisp debugger mode. +In addition to ordinary SLY commands, the following are +available:\\ + +Commands to invoke restarts: + \\[sly-db-quit] - quit + \\[sly-db-abort] - abort + \\[sly-db-continue] - continue + \\[sly-db-invoke-restart-0]-\\[sly-db-invoke-restart-9] - restart shortcuts + \\[sly-db-invoke-restart-by-name] - invoke restart by name + +Navigation commands: + \\[forward-button] - next interactive button + \\[sly-db-down] - down + \\[sly-db-up] - up + \\[sly-db-details-down] - down, with details + \\[sly-db-details-up] - up, with details + \\[sly-db-beginning-of-backtrace] - beginning of backtrace + \\[sly-db-end-of-backtrace] - end of backtrace + +Commands to examine and operate on the selected frame:\\ + \\[sly-db-show-frame-source] - show frame source + \\[sly-db-goto-source] - go to frame source + \\[sly-db-toggle-details] - toggle details + \\[sly-db-disassemble] - dissassemble frame + \\[sly-db-eval-in-frame] - prompt for a form to eval in frame + \\[sly-db-pprint-eval-in-frame] - eval in frame and pretty print result + \\[sly-db-inspect-in-frame] - inspect in frame's context + \\[sly-db-restart-frame] - restart frame + \\[sly-db-return-from-frame] - return from frame + +Miscellaneous commands:\\ + \\[sly-db-step] - step + \\[sly-db-break-with-default-debugger] - switch to native debugger + \\[sly-db-break-with-system-debugger] - switch to system debugger (gdb) + \\[sly-interactive-eval] - eval + \\[sly-db-inspect-condition] - inspect signalled condition + +Full list of commands: + +\\{sly-db-mode-map} + +Full list of frame-specific commands: + +\\{sly-db-frame-map}" + (erase-buffer) + (set-syntax-table sly-db-mode-syntax-table) + (sly-set-truncate-lines) + ;; Make original sly-connection "sticky" for SLY-DB commands in this buffer + (setq sly-buffer-connection (sly-connection)) + (setq buffer-read-only t) + (sly-mode 1) + (sly-interactive-buttons-mode 1)) + +;; Keys 0-9 are shortcuts to invoke particular restarts. +(dotimes (number 10) + (let ((fname (intern (format "sly-db-invoke-restart-%S" number))) + (docstring (format "Invoke restart numbered %S." number))) + ;; FIXME: In Emacs≥25, you could avoid `eval' and use + ;; (defalias .. (lambda .. (:documentation docstring) ...)) + ;; instead! + (eval `(defun ,fname () + ,docstring + (interactive) + (sly-db-invoke-restart ,number)) + t) + (define-key sly-db-mode-map (number-to-string number) fname))) + + +;;;;; SLY-DB buffer creation & update + +(defcustom sly-db-focus-debugger 'auto + "Control if debugger window gets focus immediately. + +If nil, the window is never focused automatically; if the symbol +`auto', the window is only focused if the user has performed no +other commands in the meantime (i.e. he/she is expecting a +possible debugger); any other non-nil value means to always +automatically focus the debugger window." + :group 'sly-debugger + :type '(choice (const always) (const never) (const auto))) + +(defun sly-filter-buffers (predicate) + "Return a list of where PREDICATE returns true. +PREDICATE is executed in the buffer to test." + (cl-remove-if-not (lambda (%buffer) + (with-current-buffer %buffer + (funcall predicate))) + (buffer-list))) + +(defun sly-db-buffers (&optional connection) + "Return a list of all sly-db buffers (belonging to CONNECTION.)" + (if connection + (sly-filter-buffers (lambda () + (and (eq sly-buffer-connection connection) + (eq major-mode 'sly-db-mode)))) + (sly-filter-buffers (lambda () (eq major-mode 'sly-db-mode))))) + +(defun sly-db-find-buffer (thread &optional connection) + (let ((connection (or connection (sly-connection)))) + (cl-find-if (lambda (buffer) + (with-current-buffer buffer + (and (eq sly-buffer-connection connection) + (eq sly-current-thread thread)))) + (sly-db-buffers)))) + +(defun sly-db-pop-to-debugger-maybe (&optional _button) + "Maybe pop to *sly-db* buffer for current context." + (interactive) + (let ((b (sly-db-find-buffer sly-current-thread))) + (if b (pop-to-buffer b) + (sly-error "Can't find a *sly-db* debugger for this context")))) + +(defsubst sly-db-get-default-buffer () + "Get a sly-db buffer. +The chosen buffer the default connection's it if exists." + (car (sly-db-buffers (sly-current-connection)))) + +(defun sly-db-pop-to-debugger () + "Pop to the first *sly-db* buffer if at least one exists." + (interactive) + (let ((b (sly-db-get-default-buffer))) + (if b (pop-to-buffer b) + (sly-error "No *sly-db* debugger buffers for this connection")))) + +(defun sly-db-get-buffer (thread &optional connection) + "Find or create a sly-db-buffer for THREAD." + (let ((connection (or connection (sly-connection)))) + (or (sly-db-find-buffer thread connection) + (let ((name (sly-buffer-name :db :connection connection + :suffix (format "thread %d" thread)))) + (with-current-buffer (generate-new-buffer name) + (setq sly-buffer-connection connection + sly-current-thread thread) + (current-buffer)))))) + +(defun sly-db-debugged-continuations (connection) + "Return the all debugged continuations for CONNECTION across SLY-DB buffers." + (cl-loop for b in (sly-db-buffers) + append (with-current-buffer b + (and (eq sly-buffer-connection connection) + sly-db-continuations)))) + +(defun sly-db-confirm-buffer-kill () + (when (or (not (process-live-p sly-buffer-connection)) + (sly-y-or-n-p "Really kill sly-db buffer and throw to toplevel?")) + (ignore-errors (sly-db-quit)) + t)) + +(defun sly-db--display-debugger (_thread) + "Display (or pop to) sly-db for THREAD as appropriate. +Also mark the window as a debugger window." + (let* ((action '(sly-db--display-in-prev-sly-db-window)) + (buffer (current-buffer)) + (win + (if (cond ((eq sly-db-focus-debugger 'auto) + (eq sly--send-last-command last-command)) + (t sly-db-focus-debugger)) + (progn + (pop-to-buffer buffer action) + (selected-window)) + (display-buffer buffer action)))) + (set-window-parameter win 'sly-db buffer) + win)) + +(defun sly-db-setup (thread level condition restarts frame-specs conts) + "Setup a new SLY-DB buffer. +CONDITION is a string describing the condition to debug. +RESTARTS is a list of strings (NAME DESCRIPTION) for each +available restart. FRAME-SPECS is a list of (NUMBER DESCRIPTION +&optional PLIST) describing the initial portion of the +backtrace. Frames are numbered from 0. CONTS is a list of +pending Emacs continuations." + (with-current-buffer (sly-db-get-buffer thread) + (cl-assert (if (equal sly-db-level level) + (equal sly-db-condition condition) + t) + () "Bug: sly-db-level is equal but condition differs\n%s\n%s" + sly-db-condition condition) + (with-selected-window (sly-db--display-debugger thread) + (unless (equal sly-db-level level) + (let ((inhibit-read-only t)) + (sly-db-mode) + (add-hook 'kill-buffer-query-functions + #'sly-db-confirm-buffer-kill + nil t) + (setq sly-current-thread thread) + (setq sly-db-level level) + (setq mode-name (format "sly-db[%d]" sly-db-level)) + (setq sly-db-condition condition) + (setq sly-db-restarts restarts) + (setq sly-db-continuations conts) + (sly-db-insert-condition condition) + (insert "\n\n" (sly-db-in-face section "Restarts:") "\n") + (setq sly-db-restart-list-start-marker (point-marker)) + (sly-db-insert-restarts restarts 0 sly-db-initial-restart-limit) + (insert "\n" (sly-db-in-face section "Backtrace:") "\n") + (setq sly-db-backtrace-start-marker (point-marker)) + (save-excursion + (if frame-specs + (sly-db-insert-frames (sly-db-prune-initial-frames frame-specs) t) + (insert "[No backtrace]"))) + (run-hooks 'sly-db-hook) + (set-syntax-table lisp-mode-syntax-table))) + (sly-recenter (point-min) 'allow-moving-point) + (when sly--stack-eval-tags + (sly-message "Entering recursive edit..") + (recursive-edit))))) + +(defun sly-db--display-in-prev-sly-db-window (buffer _alist) + (let ((window + (get-window-with-predicate + #'(lambda (w) + (let ((value (window-parameter w 'sly-db))) + (and value + (not (buffer-live-p value)))))))) + (when window + (display-buffer-record-window 'reuse window buffer) + (set-window-buffer window buffer) + window))) + +(defun sly-db--ensure-initialized (thread level) + "Initialize debugger buffer for THREAD. +If such a buffer exists for LEVEL, it is assumed to have been +sufficiently initialized, and this function does nothing." + (let ((buffer (sly-db-find-buffer thread))) + (unless (and buffer + (with-current-buffer buffer + (equal sly-db-level level))) + (sly-rex () + ('(slynk:debugger-info-for-emacs 0 10) + nil thread) + ((:ok result) + (apply #'sly-db-setup thread level result)))))) + +(defvar sly-db-exit-hook nil + "Hooks run in the debugger buffer just before exit") + +(defun sly-db-exit (thread _level &optional stepping) + "Exit from the debug level LEVEL." + (sly--when-let (sly-db (sly-db-find-buffer thread)) + (with-current-buffer sly-db + (setq kill-buffer-query-functions + (remove 'sly-db-confirm-buffer-kill kill-buffer-query-functions)) + (run-hooks 'sly-db-exit-hook) + (cond (stepping + (setq sly-db-level nil) + (run-with-timer 0.4 nil 'sly-db-close-step-buffer sly-db)) + ((not (eq sly-db (window-buffer (selected-window)))) + ;; A different window selection means an indirect, + ;; non-interactive exit, we just kill the sly-db buffer. + (kill-buffer)) + (t + (quit-window t)))))) + +(defun sly-db-close-step-buffer (buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (when (not sly-db-level) + (quit-window t))))) + + +;;;;;; SLY-DB buffer insertion + +(defun sly-db-insert-condition (condition) + "Insert the text for CONDITION. +CONDITION should be a list (MESSAGE TYPE EXTRAS). +EXTRAS is currently used for the stepper." + (cl-destructuring-bind (msg type extras) condition + (insert (sly-db-in-face topline msg) + "\n" + (sly-db-in-face condition type)) + (sly-db-dispatch-extras extras))) + +(defvar sly-db-extras-hooks nil + "Handlers for the extra options sent in a debugger invocation. +Each function is called with one argument, a list (OPTION +VALUE). It should return non-nil iff it can handle OPTION, and +thus preventing other handlers from trying. + +Functions are run in the SLDB buffer.") + +(defun sly-db-dispatch-extras (extras) + ;; this is (mis-)used for the stepper + (dolist (extra extras) + (sly-dcase extra + ((:show-frame-source n) + (sly-db-show-frame-source n)) + (t + (or (run-hook-with-args-until-success 'sly-db-extras-hooks extra) + ;;(error "Unhandled extra element:" extra) + ))))) + +(defun sly-db-insert-restarts (restarts start count) + "Insert RESTARTS and add the needed text props +RESTARTS should be a list ((NAME DESCRIPTION) ...)." + (let* ((len (length restarts)) + (end (if count (min (+ start count) len) len))) + (cl-loop for (name string) in (cl-subseq restarts start end) + for number from start + do (insert + " " (sly-db-in-face restart-number (number-to-string number)) + ": " (sly-make-action-button (format "[%s]" name) + (let ((n number)) + #'(lambda (_button) + (sly-db-invoke-restart n))) + 'restart-number number) + " " (sly-db-in-face restart string)) + (insert "\n")) + (when (< end len) + (insert (sly-make-action-button + " --more--" + #'(lambda (button) + (let ((inhibit-read-only t)) + (delete-region (button-start button) + (1+ (button-end button))) + (sly-db-insert-restarts restarts end nil) + (sly--when-let (win (get-buffer-window (current-buffer))) + (with-selected-window win + (sly-recenter (point-max)))))) + 'point-entered #'(lambda (_ new) (push-button new))) + "\n")))) + +(defun sly-db-frame-restartable-p (frame-spec) + (and (plist-get (cl-caddr frame-spec) :restartable) t)) + +(defun sly-db-prune-initial-frames (frame-specs) + "Return the prefix of FRAMES-SPECS to initially present to the user. +Regexp heuristics are used to avoid showing SLYNK-internal frames." + (let* ((case-fold-search t) + (rx "^\\([() ]\\|lambda\\)*slynk\\>")) + (or (cl-loop for frame-spec in frame-specs + until (string-match rx (cadr frame-spec)) + collect frame-spec) + frame-specs))) + +(defun sly-db-insert-frames (frame-specs more) + "Insert frames for FRAME-SPECS into buffer. +If MORE is non-nil, more frames are on the Lisp stack." + (cl-loop + for frame-spec in frame-specs + do (sly-db-insert-frame frame-spec) + finally + (when more + (insert (sly-make-action-button + " --more--\n" + (lambda (button) + (let* ((inhibit-read-only t) + (count 40) + (from (1+ (car frame-spec))) + (to (+ from count)) + (frames (sly-eval `(slynk:backtrace ,from ,to))) + (more (sly-length= frames count))) + (delete-region (button-start button) + (button-end button)) + (save-excursion + (sly-db-insert-frames frames more)) + (sly--when-let (win (get-buffer-window (current-buffer))) + (with-selected-window win + (sly-recenter (point-max)))))) + 'point-entered #'(lambda (_ new) (push-button new))))))) + +(defvar sly-db-frame-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "t") 'sly-db-toggle-details) + (define-key map (kbd "v") 'sly-db-show-frame-source) + (define-key map (kbd ".") 'sly-db-goto-source) + (define-key map (kbd "D") 'sly-db-disassemble) + (define-key map (kbd "e") 'sly-db-eval-in-frame) + (define-key map (kbd "d") 'sly-db-pprint-eval-in-frame) + (define-key map (kbd "i") 'sly-db-inspect-in-frame) + (define-key map (kbd "r") 'sly-db-restart-frame) + (define-key map (kbd "R") 'sly-db-return-from-frame) + (define-key map (kbd "RET") 'sly-db-toggle-details) + + (define-key map "s" 'sly-db-step) + (define-key map "x" 'sly-db-next) + (define-key map "o" 'sly-db-out) + (define-key map "b" 'sly-db-break-on-return) + + (define-key map "\C-c\C-c" 'sly-db-recompile-frame-source) + + (set-keymap-parent map sly-part-button-keymap) + map)) + +(defvar sly-db-frame-menu-map + (let ((map (make-sparse-keymap))) + (cl-macrolet ((item (label sym) + `(define-key map [,sym] '(menu-item ,label ,sym)))) + (item "Dissassemble" sly-db-disassemble) + (item "Eval In Context" sly-db-eval-in-frame) + (item "Eval and Pretty Print In Context" sly-db-pprint-eval-in-frame) + (item "Inspect In Context" sly-db-inspect-in-frame) + (item "Restart" sly-db-restart-frame) + (item "Return Value" sly-db-return-from-frame) + (item "Toggle Details" sly-db-toggle-details) + (item "Show Source" sly-db-show-frame-source) + (item "Go To Source" sly-db-goto-source)) + (set-keymap-parent map sly-button-popup-part-menu-keymap) + map)) + +(define-button-type 'sly-db-frame :supertype 'sly-part + 'keymap sly-db-frame-map + 'part-menu-keymap sly-db-frame-menu-map + 'action 'sly-db-toggle-details + 'mouse-action 'sly-db-toggle-details) + +(defun sly-db--guess-frame-function (frame) + (ignore-errors + (car (car (read-from-string + (replace-regexp-in-string "#" "" + (cadr frame))))))) + +(defun sly-db-frame-button (label frame face &rest props) + (apply #'sly--make-text-button label nil :type 'sly-db-frame + 'face face + 'field (car frame) + 'frame-number (car frame) + 'frame-string (cadr frame) + 'part-args (list (car frame) + (sly-db--guess-frame-function frame)) + 'part-label (format "Frame %d" (car frame)) + props)) + +(defun sly-db-frame-number-at-point () + (let ((button (sly-db-frame-button-near-point))) + (button-get button 'frame-number))) + +(defun sly-db-frame-button-near-point () + (or (sly-button-at nil 'sly-db-frame 'no-error) + (get-text-property (point) 'nearby-frame-button) + (error "No frame button here"))) + +(defun sly-db-insert-frame (frame-spec) + "Insert a frame for FRAME-SPEC." + (let* ((number (car frame-spec)) + (label (cadr frame-spec)) + (origin (point))) + (insert + (propertize (format "%2d: " number) + 'face 'sly-db-frame-label-face) + (sly-db-frame-button label frame-spec + (if (sly-db-frame-restartable-p frame-spec) + 'sly-db-restartable-frame-line-face + 'sly-db-frame-line-face)) + "\n") + (add-text-properties + origin (point) + (list 'field number + 'keymap sly-db-frame-map + 'nearby-frame-button (button-at (- (point) 2)))))) + + +;;;;;; SLY-DB examining text props +(defun sly-db--goto-last-visible-frame () + (goto-char (point-max)) + (while (not (get-text-property (point) 'frame-string)) + (goto-char (previous-single-property-change (point) 'frame-string)))) + +(defun sly-db-beginning-of-backtrace () + "Goto the first frame." + (interactive) + (goto-char sly-db-backtrace-start-marker)) + + +;;;;; SLY-DB commands +(defun sly-db-cycle () + "Cycle between restart list and backtrace." + (interactive) + (let ((pt (point))) + (cond ((< pt sly-db-restart-list-start-marker) + (goto-char sly-db-restart-list-start-marker)) + ((< pt sly-db-backtrace-start-marker) + (goto-char sly-db-backtrace-start-marker)) + (t + (goto-char sly-db-restart-list-start-marker))))) + +(defun sly-db-end-of-backtrace () + "Fetch the entire backtrace and go to the last frame." + (interactive) + (sly-db--fetch-all-frames) + (sly-db--goto-last-visible-frame)) + +(defun sly-db--fetch-all-frames () + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (sly-db--goto-last-visible-frame) + (let ((last (sly-db-frame-number-at-point))) + (goto-char (next-single-char-property-change (point) 'frame-string)) + (delete-region (point) (point-max)) + (save-excursion + (insert "\n") + (sly-db-insert-frames (sly-eval `(slynk:backtrace ,(1+ last) nil)) + nil))))) + + +;;;;;; SLY-DB show source +(defun sly-db-show-frame-source (frame-number) + "Highlight FRAME-NUMBER's expression in a source code buffer." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async + `(slynk:frame-source-location ,frame-number) + (lambda (source-location) + (sly-dcase source-location + ((:error message) + (sly-message "%s" message) + (ding)) + (t + (sly--display-source-location source-location)))))) + + +;;;;;; SLY-DB toggle details +(define-button-type 'sly-db-local-variable :supertype 'sly-part + 'sly-button-inspect + #'(lambda (frame-id var-id) + (sly-eval-for-inspector `(slynk:inspect-frame-var ,frame-id + ,var-id)) ) + 'sly-button-pretty-print + #'(lambda (frame-id var-id) + (sly-eval-describe `(slynk:pprint-frame-var ,frame-id + ,var-id))) + 'sly-button-describe + #'(lambda (frame-id var-id) + (sly-eval-describe `(slynk:describe-frame-var ,frame-id + ,var-id)))) + +(defun sly-db-local-variable-button (label frame-number var-id &rest props) + (apply #'sly--make-text-button label nil + :type 'sly-db-local-variable + 'part-args (list frame-number var-id) + 'part-label (format "Local Variable %d" var-id) props)) + +(defun sly-db-frame-details-region (frame-button) + "Get (BEG END) for FRAME-BUTTON's details, or nil if hidden" + (let ((beg (button-end frame-button)) + (end (1- (field-end (button-start frame-button) 'escape)))) + (unless (= beg end) (list beg end)))) + +(defun sly-db-toggle-details (frame-button) + "Toggle display of details for the current frame. +The details include local variable bindings and CATCH-tags." + (interactive (list (sly-db-frame-button-near-point))) + (if (sly-db-frame-details-region frame-button) + (sly-db-hide-frame-details frame-button) + (sly-db-show-frame-details frame-button))) + +(defun sly-db-show-frame-details (frame-button) + "Show details for FRAME-BUTTON" + (interactive (list (sly-db-frame-button-near-point))) + (cl-destructuring-bind (locals catches) + (sly-eval `(slynk:frame-locals-and-catch-tags + ,(button-get frame-button 'frame-number))) + (let ((inhibit-read-only t) + (inhibit-point-motion-hooks t)) + (save-excursion + (goto-char (button-end frame-button)) + (let ((indent1 " ") + (indent2 " ")) + (insert "\n" indent1 + (sly-db-in-face section (if locals "Locals:" "[No Locals]"))) + (cl-loop for i from 0 + for var in locals + with frame-number = (button-get frame-button 'frame-number) + do + (cl-destructuring-bind (&key name id value) var + (insert "\n" + indent2 + (sly-db-in-face local-name + (concat name (if (zerop id) + "" + (format "#%d" id)))) + " = " + (sly-db-local-variable-button value + frame-number + i)))) + (when catches + (insert "\n" indent1 (sly-db-in-face section "Catch-tags:")) + (dolist (tag catches) + (sly-propertize-region `(catch-tag ,tag) + (insert "\n" indent2 (sly-db-in-face catch-tag + (format "%s" tag)))))) + ;; The whole details field is propertized accordingly... + ;; + (add-text-properties (button-start frame-button) (point) + (list 'field (button-get frame-button 'field) + 'keymap sly-db-frame-map + 'nearby-frame-button frame-button)) + ;; ...but we must remember to remove the 'keymap property from + ;; any buttons inside the field + ;; + (cl-loop for pos = (point) then (button-start button) + for button = (previous-button pos) + while (and button + (> (button-start button) + (button-start frame-button))) + do (remove-text-properties (button-start button) + (button-end button) + '(keymap nil)))))) + (sly-recenter (field-end (button-start frame-button) 'escape)))) + +(defun sly-db-hide-frame-details (frame-button) + (interactive (list (sly-db-frame-button-near-point))) + (let* ((inhibit-read-only t) + (to-delete (sly-db-frame-details-region frame-button))) + (cl-assert to-delete) + (when (and (< (car to-delete) (point)) + (< (point) (cadr to-delete))) + (goto-char (button-start frame-button))) + (apply #'delete-region to-delete))) + +(defun sly-db-disassemble (frame-number) + "Disassemble the code for frame with FRAME-NUMBER." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-disassemble ,frame-number) + (lambda (result) + (sly-show-description result nil)))) + + +;;;;;; SLY-DB eval and inspect + +(defun sly-db-eval-in-frame (frame-number string package) + "Prompt for an expression and evaluate it in the selected frame." + (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) + (sly-eval-async `(slynk:eval-string-in-frame ,string ,frame-number ,package) + 'sly-display-eval-result)) + +(defun sly-db-pprint-eval-in-frame (frame-number string package) + "Prompt for an expression, evaluate in selected frame, pretty-print result." + (interactive (sly-db-frame-eval-interactive "Eval in frame (%s)> ")) + (sly-eval-async + `(slynk:pprint-eval-string-in-frame ,string ,frame-number ,package) + (lambda (result) + (sly-show-description result nil)))) + +(defun sly-db-frame-eval-interactive (fstring) + (let* ((frame-number (sly-db-frame-number-at-point)) + (pkg (sly-eval `(slynk:frame-package-name ,frame-number)))) + (list frame-number + (let ((sly-buffer-package pkg)) + (sly-read-from-minibuffer (format fstring pkg))) + pkg))) + +(defun sly-db-inspect-in-frame (frame-number string) + "Prompt for an expression and inspect it in the selected frame." + (interactive (list + (sly-db-frame-number-at-point) + (sly-read-from-minibuffer + "Inspect in frame (evaluated): " + (sly-sexp-at-point)))) + (sly-eval-for-inspector `(slynk:inspect-in-frame ,string ,frame-number))) + +(defun sly-db-inspect-condition () + "Inspect the current debugger condition." + (interactive) + (sly-eval-for-inspector '(slynk:inspect-current-condition))) + +(defun sly-db-print-condition () + (interactive) + (sly-eval-describe `(slynk:sdlb-print-condition))) + + +;;;;;; SLY-DB movement + +(defun sly-db-down (arg) + "Move down ARG frames. With negative ARG, move up." + (interactive "p") + (cl-loop + for i from 0 below (abs arg) + do (cl-loop + for tries from 0 below 2 + for pos = (point) then next-change + for next-change = (funcall (if (cl-minusp arg) + #'previous-single-char-property-change + #'next-single-char-property-change) + pos 'frame-number) + for prop-value = (get-text-property next-change 'frame-number) + when prop-value do (goto-char next-change) + until prop-value))) + +(defun sly-db-up (arg) + "Move up ARG frames. With negative ARG, move down." + (interactive "p") + (sly-db-down (- (or arg 1)))) + +(defun sly-db-sugar-move (move-fn arg) + (let ((current-frame-button (sly-db-frame-button-near-point))) + (when (and current-frame-button + (sly-db-frame-details-region current-frame-button)) + (sly-db-hide-frame-details current-frame-button))) + (funcall move-fn arg) + (let ((frame-button (sly-db-frame-button-near-point))) + (when frame-button + (sly-db-show-frame-source (button-get frame-button 'frame-number)) + (sly-db-show-frame-details frame-button)))) + +(defun sly-db-details-up (arg) + "Move up ARG frames and show details." + (interactive "p") + (sly-db-sugar-move 'sly-db-up arg)) + +(defun sly-db-details-down (arg) + "Move down ARG frames and show details." + (interactive "p") + (sly-db-sugar-move 'sly-db-down arg)) + + +;;;;;; SLY-DB restarts + +(defun sly-db-quit () + "Quit to toplevel." + (interactive) + (cl-assert sly-db-restarts () "sly-db-quit called outside of sly-db buffer") + (sly-rex () ('(slynk:throw-to-toplevel)) + ((:ok x) (error "sly-db-quit returned [%s]" x)) + ((:abort _)))) + +(defun sly-db-continue () + "Invoke the \"continue\" restart." + (interactive) + (cl-assert sly-db-restarts () "sly-db-continue called outside of sly-db buffer") + (sly-rex () + ('(slynk:sly-db-continue)) + ((:ok _) + (sly-message "No restart named continue") + (ding)) + ((:abort _)))) + +(defun sly-db-abort () + "Invoke the \"abort\" restart." + (interactive) + (sly-eval-async '(slynk:sly-db-abort) + (lambda (v) (sly-message "Restart returned: %S" v)))) + +(defun sly-db-invoke-restart (restart-number) + "Invoke the restart number NUMBER. +Interactively get the number from a button at point." + (interactive (button-get (sly-button-at (point)) 'restart-number)) + (sly-rex () + ((list 'slynk:invoke-nth-restart-for-emacs sly-db-level restart-number)) + ((:ok value) (sly-message "Restart returned: %s" value)) + ((:abort _)))) + +(defun sly-db-invoke-restart-by-name (restart-name) + (interactive (list (let ((completion-ignore-case t)) + (completing-read "Restart: " sly-db-restarts nil t + "" + 'sly-db-invoke-restart-by-name)))) + (sly-db-invoke-restart (cl-position restart-name sly-db-restarts + :test 'string= :key #'cl-first))) + +(defun sly-db-break-with-default-debugger (&optional dont-unwind) + "Enter default debugger." + (interactive "P") + (sly-rex () + ((list 'slynk:sly-db-break-with-default-debugger + (not (not dont-unwind))) + nil sly-current-thread) + ((:abort _)))) + +(defun sly-db-break-with-system-debugger (&optional lightweight) + "Enter system debugger (gdb)." + (interactive "P") + (sly-attach-gdb sly-buffer-connection lightweight)) + +(defun sly-attach-gdb (connection &optional lightweight) + "Run `gud-gdb'on the connection with PID `pid'. + +If `lightweight' is given, do not send any request to the +inferior Lisp (e.g. to obtain default gdb config) but only +operate from the Emacs side; intended for cases where the Lisp is +truly screwed up." + (interactive + (list (sly-read-connection "Attach gdb to: " (sly-connection)) "P")) + (let ((pid (sly-pid connection)) + (file (sly-lisp-implementation-program connection)) + (commands (unless lightweight + (let ((sly-dispatching-connection connection)) + (sly-eval `(slynk:gdb-initial-commands)))))) + (gud-gdb (format "gdb -p %d %s" pid (or file ""))) + (with-current-buffer gud-comint-buffer + (dolist (cmd commands) + ;; First wait until gdb was initialized, then wait until current + ;; command was processed. + (while (not (looking-back comint-prompt-regexp (line-beginning-position) + nil)) + (sit-for 0.01)) + ;; We do not use `gud-call' because we want the initial commands + ;; to be displayed by the user so he knows what he's got. + (insert cmd) + (comint-send-input))))) + +(defun sly-read-connection (prompt &optional initial-value) + "Read a connection from the minibuffer. +Return the net process, or nil." + (cl-assert (memq initial-value sly-net-processes)) + (let* ((to-string (lambda (p) + (format "%s (pid %d)" + (sly-connection-name p) (sly-pid p)))) + (candidates (mapcar (lambda (p) (cons (funcall to-string p) p)) + sly-net-processes))) + (cdr (assoc (completing-read prompt candidates + nil t (funcall to-string initial-value)) + candidates)))) + +(defun sly-db-step (frame-number) + "Step to next basic-block boundary." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-step ,frame-number))) + +(defun sly-db-next (frame-number) + "Step over call." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-next ,frame-number))) + +(defun sly-db-out (frame-number) + "Resume stepping after returning from this function." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-out ,frame-number))) + +(defun sly-db-break-on-return (frame-number) + "Set a breakpoint at the current frame. +The debugger is entered when the frame exits." + (interactive (list (sly-db-frame-number-at-point))) + (sly-eval-async `(slynk:sly-db-break-on-return ,frame-number) + (lambda (msg) (sly-message "%s" msg)))) + +(defun sly-db-break (name) + "Set a breakpoint at the start of the function NAME." + (interactive (list (sly-read-symbol-name "Function: " t))) + (sly-eval-async `(slynk:sly-db-break ,name) + (lambda (msg) (sly-message "%s" msg)))) + +(defun sly-db-return-from-frame (frame-number string) + "Reads an expression in the minibuffer and causes the function to +return that value, evaluated in the context of the frame." + (interactive (list (sly-db-frame-number-at-point) + (sly-read-from-minibuffer "Return from frame: "))) + (sly-rex () + ((list 'slynk:sly-db-return-from-frame frame-number string)) + ((:ok value) (sly-message "%s" value)) + ((:abort _)))) + +(defun sly-db-restart-frame (frame-number) + "Causes the frame to restart execution with the same arguments as it +was called originally." + (interactive (list (sly-db-frame-number-at-point))) + (sly-rex () + ((list 'slynk:restart-frame frame-number)) + ((:ok value) (sly-message "%s" value)) + ((:abort _)))) + +(defun sly-toggle-break-on-signals () + "Toggle the value of *break-on-signals*." + (interactive) + (sly-eval-async `(slynk:toggle-break-on-signals) + (lambda (msg) (sly-message "%s" msg)))) + + +;;;;;; SLY-DB recompilation commands + +(defun sly-db-recompile-frame-source (frame-number &optional raw-prefix-arg) + (interactive + (list (sly-db-frame-number-at-point) current-prefix-arg)) + (sly-eval-async + `(slynk:frame-source-location ,frame-number) + (let ((policy (sly-compute-policy raw-prefix-arg))) + (lambda (source-location) + (sly-dcase source-location + ((:error message) + (sly-message "%s" message) + (ding)) + (t + (let ((sly-compilation-policy policy)) + (sly-recompile-location source-location)))))))) + + +;;;; Thread control panel + +(defvar sly-threads-buffer-timer nil) + +(defcustom sly-threads-update-interval nil + "Interval at which the list of threads will be updated." + :type '(choice + (number :value 0.5) + (const nil)) + :group 'sly-ui) + +(defun sly-list-threads () + "Display a list of threads." + (interactive) + (let ((name (sly-buffer-name :threads + :connection t))) + (sly-with-popup-buffer (name :connection t + :mode 'sly-thread-control-mode) + (sly-update-threads-buffer (current-buffer)) + (goto-char (point-min)) + (when sly-threads-update-interval + (when sly-threads-buffer-timer + (cancel-timer sly-threads-buffer-timer)) + (setq sly-threads-buffer-timer + (run-with-timer + sly-threads-update-interval + sly-threads-update-interval + 'sly-update-threads-buffer + (current-buffer)))) + (add-hook 'kill-buffer-hook 'sly--threads-buffer-teardown + 'append 'local)))) + +(defun sly--threads-buffer-teardown () + (when sly-threads-buffer-timer + (cancel-timer sly-threads-buffer-timer)) + (when (process-live-p sly-buffer-connection) + (sly-eval-async `(slynk:quit-thread-browser)))) + +(defun sly-update-threads-buffer (&optional buffer) + (interactive) + (with-current-buffer (or buffer + (current-buffer)) + (sly-eval-async '(slynk:list-threads) + #'(lambda (threads) + (with-current-buffer (current-buffer) + (sly--display-threads threads)))))) + +(defun sly-move-point (position) + "Move point in the current buffer and in the window the buffer is displayed." + (let ((window (get-buffer-window (current-buffer) t))) + (goto-char position) + (when window + (set-window-point window position)))) + +(defun sly--display-threads (threads) + (let* ((inhibit-read-only t) + (old-thread-id (get-text-property (point) 'thread-id)) + (old-line (line-number-at-pos)) + (old-column (current-column))) + (erase-buffer) + (sly-insert-threads threads) + (let ((new-line (cl-position old-thread-id (cdr threads) + :key #'car :test #'equal))) + (goto-char (point-min)) + (forward-line (or new-line old-line)) + (move-to-column old-column) + (sly-move-point (point))))) + +(defun sly-transpose-lists (list-of-lists) + (let ((ncols (length (car list-of-lists)))) + (cl-loop for col-index below ncols + collect (cl-loop for row in list-of-lists + collect (elt row col-index))))) + +(defun sly-insert-table-row (line line-props col-props col-widths) + (sly-propertize-region line-props + (cl-loop for string in line + for col-prop in col-props + for width in col-widths do + (sly-insert-propertized col-prop string) + (insert-char ?\ (- width (length string)))))) + +(defun sly-insert-table (rows header row-properties column-properties) + "Insert a \"table\" so that the columns are nicely aligned." + (let* ((ncols (length header)) + (lines (cons header rows)) + (widths (cl-loop for columns in (sly-transpose-lists lines) + collect (1+ (cl-loop for cell in columns + maximize (length cell))))) + (header-line (with-temp-buffer + (sly-insert-table-row + header nil (make-list ncols nil) widths) + (buffer-string)))) + (cond ((boundp 'header-line-format) + (setq header-line-format header-line)) + (t (insert header-line "\n"))) + (cl-loop for line in rows for line-props in row-properties do + (sly-insert-table-row line line-props column-properties widths) + (insert "\n")))) + +(defvar sly-threads-table-properties + '(nil (face bold))) + +(defun sly-insert-threads (threads) + (let* ((labels (car threads)) + (threads (cdr threads)) + (header (cl-loop for label in labels collect + (capitalize (substring (symbol-name label) 1)))) + (rows (cl-loop for thread in threads collect + (cl-loop for prop in thread collect + (format "%s" prop)))) + (line-props (cl-loop for (id) in threads for i from 0 + collect `(thread-index ,i thread-id ,id))) + (col-props (cl-loop for nil in labels for i from 0 collect + (nth i sly-threads-table-properties)))) + (sly-insert-table rows header line-props col-props))) + + +;;;;; Major mode +(defvar sly-thread-control-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'sly-thread-attach) + (define-key map "d" 'sly-thread-debug) + (define-key map "g" 'sly-update-threads-buffer) + (define-key map "k" 'sly-thread-kill) + (define-key map "q" 'quit-window) + map)) + +(define-derived-mode sly-thread-control-mode fundamental-mode + "Threads" + "SLY Thread Control Panel Mode. + +\\{sly-thread-control-mode-map}" + (when sly-truncate-lines + (set (make-local-variable 'truncate-lines) t)) + (read-only-mode 1) + (sly-mode 1) + (setq buffer-undo-list t)) + +(defun sly-thread-kill () + (interactive) + (sly-eval `(cl:mapc 'slynk:kill-nth-thread + ',(sly-get-properties 'thread-index))) + (call-interactively 'sly-update-threads-buffer)) + +(defun sly-get-region-properties (prop start end) + (cl-loop for position = (if (get-text-property start prop) + start + (next-single-property-change start prop)) + then (next-single-property-change position prop) + while (<= position end) + collect (get-text-property position prop))) + +(defun sly-get-properties (prop) + (if (use-region-p) + (sly-get-region-properties prop + (region-beginning) + (region-end)) + (let ((value (get-text-property (point) prop))) + (when value + (list value))))) + +(defun sly-thread-attach () + (interactive) + (let ((id (get-text-property (point) 'thread-index)) + (file (sly-slynk-port-file))) + (sly-eval-async `(slynk:start-slynk-server-in-thread ,id ,file))) + (sly-read-port-and-connect nil)) + +(defun sly-thread-debug () + (interactive) + (let ((id (get-text-property (point) 'thread-index))) + (sly-eval-async `(slynk:debug-nth-thread ,id)))) + + +;;;;; Connection listing + +(defvar sly-connection-list-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "d" 'sly-connection-list-make-default) + (define-key map "g" 'sly-update-connection-list) + (define-key map (kbd "RET") 'sly-connection-list-default-action) + (define-key map (kbd "C-m") 'sly-connection-list-default-action) + (define-key map (kbd "C-k") 'sly-quit-connection-at-point) + (define-key map (kbd "R") 'sly-restart-connection-at-point) + (define-key map (kbd "q") 'quit-window) + map)) + +(define-derived-mode sly-connection-list-mode tabulated-list-mode + "SLY-Connections" + "SLY Connection List Mode. + +\\{sly-connection-list-mode-map}" + (set (make-local-variable 'tabulated-list-format) + `[("Default" 8) ("Name" 24 t) ("Host" 12) + ("Port" 6) ("Pid" 6 t) ("Type" 1000 t)]) + (tabulated-list-init-header)) + +(defun sly--connection-at-point () + (or (get-text-property (point) 'tabulated-list-id) + (error "No connection at point"))) + +(defvar sly-connection-list-button-action nil) + +(defun sly-connection-list-default-action (connection) + (interactive (list (sly--connection-at-point))) + (funcall sly-connection-list-button-action connection)) + +(defun sly-update-connection-list () + (interactive) + (set (make-local-variable 'tabulated-list-entries) + (mapcar + #'(lambda (p) + (list p + `[,(if (eq sly-default-connection p) "*" " ") + (,(file-name-nondirectory (or (sly-connection-name p) + "unknown")) + action + ,#'(lambda (_button) + (and sly-connection-list-button-action + (funcall sly-connection-list-button-action p)))) + ,(car (process-contact p)) + ,(format "%s" (cl-second (process-contact p))) + ,(format "%s" (sly-pid p)) + ,(or (sly-lisp-implementation-type p) + "unknown")])) + (reverse sly-net-processes))) + (let ((p (point))) + (tabulated-list-print) + (goto-char p))) + +(defun sly-quit-connection-at-point (connection) + (interactive (list (sly--connection-at-point))) + (let ((sly-dispatching-connection connection) + (end (time-add (current-time) (seconds-to-time 3)))) + (sly-quit-lisp t) + (while (memq connection sly-net-processes) + (when (time-less-p end (current-time)) + (sly-message "Quit timeout expired. Disconnecting.") + (delete-process connection)) + (sit-for 0.1))) + (sly-update-connection-list)) + +(defun sly-restart-connection-at-point (connection) + (interactive (list (sly--connection-at-point))) + (when (sly-y-or-n-p "Really restart '%s'" (sly-connection-name connection)) + (let ((sly-dispatching-connection connection)) + (sly-restart-inferior-lisp)))) + +(defun sly-connection-list-make-default () + "Make the connection at point the default connection." + (interactive) + (sly-select-connection (sly--connection-at-point)) + (sly-update-connection-list)) + +(defun sly-list-connections () + "Display a list of all connections." + (interactive) + (sly-with-popup-buffer ((sly-buffer-name :connections) + :mode 'sly-connection-list-mode) + (sly-update-connection-list))) + + + +;;;; Inspector + +(defgroup sly-inspector nil + "Options for the SLY inspector." + :prefix "sly-inspector-" + :group 'sly) + +(defvar sly--this-inspector-name nil + "Buffer-local inspector name (a string), or nil") + +(cl-defun sly-eval-for-inspector (slyfun-and-args + &key (error-message "Couldn't inspect") + restore-point + save-selected-window + (inspector-name sly--this-inspector-name) + opener) + (if (cl-some #'listp slyfun-and-args) + (sly-warning + "`sly-eval-for-inspector' not meant to be passed a generic form")) + (let ((pos (and (eq major-mode 'sly-inspector-mode) + (sly-inspector-position)))) + (sly-eval-async `(slynk:eval-for-inspector + ,sly--this-inspector-name ; current inspector, if any + ,inspector-name ; target inspector, if any + ',(car slyfun-and-args) + ,@(cdr slyfun-and-args)) + (or opener + (lambda (results) + (let ((opener (lambda () + (sly--open-inspector + results + :point (and restore-point pos) + :inspector-name inspector-name + :switch (not save-selected-window))))) + (cond (results + (funcall opener)) + (t + (sly-message error-message))))))))) + +(defun sly-read-inspector-name () + (let* ((names (cl-loop for b in (buffer-list) + when (with-current-buffer b + (and (eq sly-buffer-connection + (sly-current-connection)) + (eq major-mode 'sly-inspector-mode))) + when (buffer-local-value 'sly--this-inspector-name b) + collect it)) + (result (completing-read "Inspector name: " (cons "default" + names) + nil nil nil nil "default"))) + (unless (string= result "default") + result))) + +(defun sly-maybe-read-inspector-name () + (or (and current-prefix-arg + (sly-read-inspector-name)) + sly--this-inspector-name)) + +(defun sly-inspect (string &optional inspector-name) + "Eval an expression and inspect the result." + (interactive + (let* ((name (sly-maybe-read-inspector-name)) + (string (sly-read-from-minibuffer + (concat "Inspect value" + (and name + (format " in inspector \"%s\"" name)) + " (evaluated): ") + (sly-sexp-at-point 'interactive nil nil)))) + (list string name))) + (sly-eval-for-inspector `(slynk:init-inspector ,string) + :inspector-name inspector-name)) + +(defvar sly-inspector-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "l" 'sly-inspector-pop) + (define-key map "n" 'sly-inspector-next) + (define-key map [mouse-6] 'sly-inspector-pop) + (define-key map [mouse-7] 'sly-inspector-next) + + (define-key map " " 'sly-inspector-next) + (define-key map "D" 'sly-inspector-describe-inspectee) + (define-key map "e" 'sly-inspector-eval) + (define-key map "h" 'sly-inspector-history) + (define-key map "g" 'sly-inspector-reinspect) + (define-key map ">" 'sly-inspector-fetch-all) + (define-key map "q" 'sly-inspector-quit) + + (set-keymap-parent map button-buffer-map) + map)) + +(define-derived-mode sly-inspector-mode fundamental-mode + "SLY-Inspector" + " +\\{sly-inspector-mode-map}" + (set-syntax-table lisp-mode-syntax-table) + (sly-set-truncate-lines) + (setq buffer-read-only t) + (sly-mode 1)) + +(define-button-type 'sly-inspector-part :supertype 'sly-part + 'sly-button-inspect + #'(lambda (id) + (sly-eval-for-inspector `(slynk:inspect-nth-part ,id) + :inspector-name (sly-maybe-read-inspector-name))) + 'sly-button-pretty-print + #'(lambda (id) + (sly-eval-describe `(slynk:pprint-inspector-part ,id))) + 'sly-button-describe + #'(lambda (id) + (sly-eval-describe `(slynk:describe-inspector-part ,id))) + 'sly-button-show-source + #'(lambda (id) + (sly-eval-async + `(slynk:find-source-location-for-emacs '(:inspector ,id)) + #'(lambda (result) + (sly--display-source-location result 'noerror))))) + +(defun sly-inspector-part-button (label id &rest props) + (apply #'sly--make-text-button + label nil + :type 'sly-inspector-part + 'part-args (list id) + 'part-label "Inspector Object" + props)) + +(defmacro sly-inspector-fontify (face string) + `(sly-add-face ',(intern (format "sly-inspector-%s-face" face)) ,string)) + +(cl-defun sly--open-inspector (inspected-parts + &key point kill-hook inspector-name (switch t)) + "Display INSPECTED-PARTS in a new inspector window. +Optionally set point to POINT. If KILL-HOOK is provided, it is +added to local KILL-BUFFER hooks for the inspector +buffer. INSPECTOR-NAME is the name of the target inspector, or +nil if the default one is to be used. SWITCH indicates the +buffer should be switched to (defaults to t)" + (sly-with-popup-buffer ((sly-buffer-name :inspector + :connection t + :suffix inspector-name) + :mode 'sly-inspector-mode + :select switch + :same-window-p + (and (eq major-mode 'sly-inspector-mode) + (or (null inspector-name) + (eq sly--this-inspector-name inspector-name))) + :connection t) + (when kill-hook + (add-hook 'kill-buffer-hook kill-hook t t)) + (set (make-local-variable 'sly--this-inspector-name) inspector-name) + (cl-destructuring-bind (&key id title content) inspected-parts + (cl-macrolet ((fontify (face string) + `(sly-inspector-fontify ,face ,string))) + (insert (sly-inspector-part-button title id 'skip t)) + (while (eq (char-before) ?\n) + (backward-delete-char 1)) + (insert "\n" (fontify label "--------------------") "\n") + (save-excursion + (sly-inspector-insert-content content)) + (when point + (cl-check-type point cons) + (ignore-errors + (goto-char (point-min)) + (forward-line (1- (car point))) + (move-to-column (cdr point)))))) + (buffer-disable-undo))) + +(defvar sly-inspector-limit 500) + +(defun sly-inspector-insert-content (content) + (sly-inspector-fetch-chunk + content nil + (lambda (chunk) + (let ((inhibit-read-only t)) + (sly-inspector-insert-chunk chunk t t))))) + +(defun sly-inspector-insert-chunk (chunk prev next) + "Insert CHUNK at point. +If PREV resp. NEXT are true insert more-buttons as needed." + (cl-destructuring-bind (ispecs len start end) chunk + (when (and prev (> start 0)) + (sly-inspector-insert-more-button start t)) + (mapc #'sly-inspector-insert-ispec ispecs) + (when (and next (< end len)) + (sly-inspector-insert-more-button end nil)))) + +(defun sly-inspector-insert-ispec (ispec) + (insert + (if (stringp ispec) ispec + (sly-dcase ispec + ((:value string id) + (sly-inspector-part-button string id)) + ((:label string) + (sly-inspector-fontify label string)) + ((:action string id) + (sly-make-action-button + string + #'(lambda (_button) + (sly-eval-for-inspector `(slynk::inspector-call-nth-action ,id) + :restore-point t)))))))) + +(defun sly-inspector-position () + "Return a pair (Y-POSITION X-POSITION) representing the +position of point in the current buffer." + ;; We make sure we return absolute coordinates even if the user has + ;; narrowed the buffer. + ;; FIXME: why would somebody narrow the buffer? + (save-restriction + (widen) + (cons (line-number-at-pos) + (current-column)))) + +(defun sly-inspector-pop () + "Reinspect the previous object." + (interactive) + (sly-eval-for-inspector `(slynk:inspector-pop) + :error-message "No previous object")) + +(defun sly-inspector-next () + "Inspect the next object in the history." + (interactive) + (sly-eval-for-inspector `(slynk:inspector-next) + :error-message "No next object")) + +(defun sly-inspector-quit (&optional reset) + "Quit the inspector. If RESET, clear Lisp-side history. +If RESET, any references to inspectee's that may be holding up +garbage collection are released. If RESET, the buffer is +killed (since it would become useless otherwise), else it is just +buried." + (interactive "P") + (when reset (sly-eval-async `(slynk:quit-inspector))) + (quit-window reset)) + +(defun sly-inspector-describe-inspectee () + "Describe the currently inspected object" + (interactive) + (sly-eval-describe `(slynk:describe-inspectee))) + +(defun sly-inspector-eval (string) + "Eval an expression in the context of the inspected object. +The `*' variable will be bound to the inspected object." + (interactive (list (sly-read-from-minibuffer "Inspector eval: "))) + (sly-eval-with-transcript `(slynk:inspector-eval ,string))) + +(defun sly-inspector-history () + "Show the previously inspected objects." + (interactive) + (sly-eval-describe `(slynk:inspector-history))) + +(defun sly-inspector-reinspect (&optional inspector-name) + (interactive (list (sly-maybe-read-inspector-name))) + (sly-eval-for-inspector `(slynk:inspector-reinspect) + :inspector-name inspector-name)) + +(defun sly-inspector-toggle-verbose () + (interactive) + (sly-eval-for-inspector `(slynk:inspector-toggle-verbose))) + +(defun sly-inspector-insert-more-button (index previous) + (insert (sly-make-action-button + (if previous " [--more--]\n" " [--more--]") + #'sly-inspector-fetch-more + 'range-args (list index previous)))) + +(defun sly-inspector-fetch-all () + "Fetch all inspector contents and go to the end." + (interactive) + (let ((button (button-at (1- (point-max))))) + (cond ((and button + (button-get button 'range-args)) + (let (sly-inspector-limit) + (sly-inspector-fetch-more button))) + (t + (sly-error "No more elements to fetch"))))) + +(defun sly-inspector-fetch-more (button) + (cl-destructuring-bind (index prev) (button-get button 'range-args) + (sly-inspector-fetch-chunk + (list '() (1+ index) index index) prev + (sly-rcurry + (lambda (chunk prev) + (let ((inhibit-read-only t)) + (delete-region (button-start button) (button-end button)) + (sly-inspector-insert-chunk chunk prev (not prev)))) + prev)))) + +(defun sly-inspector-fetch-chunk (chunk prev cont) + (sly-inspector-fetch chunk sly-inspector-limit prev cont)) + +(defun sly-inspector-fetch (chunk limit prev cont) + (cl-destructuring-bind (from to) + (sly-inspector-next-range chunk limit prev) + (cond ((and from to) + (sly-eval-for-inspector + `(slynk:inspector-range ,from ,to) + :opener (sly-rcurry (lambda (chunk2 chunk1 limit prev cont) + (sly-inspector-fetch + (sly-inspector-join-chunks chunk1 chunk2) + limit prev cont)) + chunk limit prev cont))) + (t (funcall cont chunk))))) + +(defun sly-inspector-next-range (chunk limit prev) + (cl-destructuring-bind (_ len start end) chunk + (let ((count (- end start))) + (cond ((and prev (< 0 start) (or (not limit) (< count limit))) + (list (if limit (max (- end limit) 0) 0) start)) + ((and (not prev) (< end len) (or (not limit) (< count limit))) + (list end (if limit (+ start limit) most-positive-fixnum))) + (t '(nil nil)))))) + +(defun sly-inspector-join-chunks (chunk1 chunk2) + (cl-destructuring-bind (i1 _l1 s1 e1) chunk1 + (cl-destructuring-bind (i2 l2 s2 e2) chunk2 + (cond ((= e1 s2) + (list (append i1 i2) l2 s1 e2)) + ((= e2 s1) + (list (append i2 i1) l2 s2 e1)) + (t (error "Invalid chunks")))))) + + +;;;; Indentation + +(defun sly-update-indentation () + "Update indentation for all macros defined in the Lisp system." + (interactive) + (sly-eval-async '(slynk:update-indentation-information))) + +(defvar sly-indentation-update-hooks) + +(defun sly-intern-indentation-spec (spec) + (cond ((consp spec) + (cons (sly-intern-indentation-spec (car spec)) + (sly-intern-indentation-spec (cdr spec)))) + ((stringp spec) + (intern spec)) + (t + spec))) + +;; FIXME: restore the old version without per-package +;; stuff. sly-indentation.el should be able tho disable the simple +;; version if needed. +(defun sly-handle-indentation-update (alist) + "Update Lisp indent information. + +ALIST is a list of (SYMBOL-NAME . INDENT-SPEC) of proposed indentation +settings for `sly-common-lisp-indent-function'. The appropriate property +is setup, unless the user already set one explicitly." + (dolist (info alist) + (let ((symbol (intern (car info))) + (indent (sly-intern-indentation-spec (cl-second info))) + (packages (cl-third info))) + (if (and (boundp 'sly-common-lisp-system-indentation) + (fboundp 'sly-update-system-indentation)) + ;; A table provided by sly-cl-indent.el. + (funcall #'sly-update-system-indentation symbol indent packages) + ;; Does the symbol have an indentation value that we set? + (when (equal (get symbol 'sly-common-lisp-indent-function) + (get symbol 'sly-indent)) + (put symbol 'sly-common-lisp-indent-function indent) + (put symbol 'sly-indent indent))) + (run-hook-with-args 'sly-indentation-update-hooks + symbol indent packages)))) + + +;;;; Contrib modules + +(defun sly-contrib--load-slynk-dependencies () + (let ((needed (cl-remove-if (lambda (s) + (cl-find (symbol-name s) + (sly-lisp-modules) + :key #'downcase + :test #'string=)) + sly-contrib--required-slynk-modules + :key #'car))) + (when needed + ;; No asynchronous request because with :SPAWN that could result + ;; in the attempt to load modules concurrently which may not be + ;; supported by the host Lisp. + (sly-eval `(slynk:slynk-add-load-paths ',(cl-remove-duplicates + (mapcar #'cl-second needed) + :test #'string=))) + (let* ((result (sly-eval + `(slynk:slynk-require + ',(mapcar #'symbol-name (mapcar #'cl-first needed))))) + (all-modules (cl-first result)) + (loaded-now (cl-second result))) + ;; check if everything went OK + ;; + (cl-loop for n in needed + unless (cl-find (cl-first n) loaded-now :test #'string=) + + ;; string= compares symbols and strings nicely + ;; + do (when (y-or-n-p (format + "\ +Watch out! SLY failed to load SLYNK module %s for contrib %s!\n +Disable it?" (cl-first n) (cl-third n))) + (sly-disable-contrib (cl-third n)) + (sly-temp-message 3 3 "\ +You'll need to re-enable %s manually with `sly-enable-contrib'\ +if/when you fix the error" (cl-third n)))) + ;; Update the connection-local list of all *MODULES* + ;; + (setf (sly-lisp-modules) all-modules))))) + +(cl-defstruct (sly-contrib + (:conc-name sly-contrib--)) + enabled-p + name + sly-dependencies + slynk-dependencies + enable + disable + authors + license) + +(defmacro define-sly-contrib (name _docstring &rest clauses) + (declare (indent 1)) + (cl-destructuring-bind (&key sly-dependencies + slynk-dependencies + on-load + on-unload + authors + license) + (cl-loop for (key . value) in clauses append `(,key ,value)) + (cl-labels + ((enable-fn (c) (intern (concat (symbol-name c) "-init"))) + (disable-fn (c) (intern (concat (symbol-name c) "-unload"))) + (path-sym (c) (intern (concat (symbol-name c) "--path"))) + (contrib-sym (c) (intern (concat (symbol-name c) "--contrib")))) + `(progn + (defvar ,(path-sym name)) + (defvar ,(contrib-sym name)) + (setq ,(path-sym name) (and load-file-name + (file-name-directory load-file-name))) + (eval-when-compile + (when byte-compile-current-file; protect against eager macro expansion + (add-to-list 'load-path + (file-name-as-directory + (file-name-directory byte-compile-current-file))))) + (setq ,(contrib-sym name) + (put 'sly-contribs ',name + (make-sly-contrib + :name ',name :authors ',authors :license ',license + :sly-dependencies ',sly-dependencies + :slynk-dependencies ',slynk-dependencies + :enable ',(enable-fn name) :disable ',(disable-fn name)))) + ,@(mapcar (lambda (d) `(require ',d)) sly-dependencies) + (defun ,(enable-fn name) () + (mapc #'funcall (mapcar + #'sly-contrib--enable + (cl-remove-if #'sly-contrib--enabled-p + (list ,@(mapcar #'contrib-sym + sly-dependencies))))) + (cl-loop for dep in ',slynk-dependencies + do (cl-pushnew (list dep ,(path-sym name) ',name) + sly-contrib--required-slynk-modules + :key #'cl-first)) + ;; FIXME: It's very tricky to do Slynk calls like + ;; `sly-contrib--load-slynk-dependencies' here, and it this + ;; should probably loop all connections. Anyway, we try + ;; ensure this can only happen from an interactive + ;; `sly-setup' call. + ;; + (when (and (eq this-command 'sly-setup) + (sly-connected-p)) + (sly-contrib--load-slynk-dependencies)) + ,@on-load + (setf (sly-contrib--enabled-p ,(contrib-sym name)) t)) + (defun ,(disable-fn name) () + ,@on-unload + (cl-loop for dep in ',slynk-dependencies + do (setq sly-contrib--required-slynk-modules + (cl-remove dep sly-contrib--required-slynk-modules + :key #'cl-first))) + (sly-warning "Disabling contrib %s" ',name) + (mapc #'funcall (mapcar + #'sly-contrib--disable + (cl-remove-if-not #'sly-contrib--enabled-p + (list ,@(mapcar #'contrib-sym + sly-dependencies))))) + (setf (sly-contrib--enabled-p ,(contrib-sym name)) nil)))))) + +(defun sly-contrib--all-contribs () + "All defined `sly-contrib' objects." + (cl-loop for (nil val) on (symbol-plist 'sly-contribs) by #'cddr + when (sly-contrib-p val) + collect val)) + +(defun sly-contrib--all-dependencies (contrib) + "Contrib names recursively needed by CONTRIB, including self." + (sly--contrib-safe contrib + (cons contrib + (cl-mapcan #'sly-contrib--all-dependencies + (sly-contrib--sly-dependencies + (sly-contrib--find-contrib contrib)))))) + +(defun sly-contrib--find-contrib (designator) + (if (sly-contrib-p designator) + designator + (or (get 'sly-contribs designator) + (error "Unknown contrib: %S" designator)))) + +(defun sly-contrib--read-contrib-name () + (let ((names (cl-loop for c in (sly-contrib--all-contribs) collect + (symbol-name (sly-contrib--name c))))) + (intern (completing-read "Contrib: " names nil t)))) + +(defun sly-enable-contrib (name) + "Attempt to enable contrib NAME." + (interactive (list (sly-contrib--read-contrib-name))) + (sly--contrib-safe name + (funcall (sly-contrib--enable (sly-contrib--find-contrib name))))) + +(defun sly-disable-contrib (name) + "Attempt to disable contrib NAME." + (interactive (list (sly-contrib--read-contrib-name))) + (sly--contrib-safe name + (funcall (sly-contrib--disable (sly-contrib--find-contrib name))))) + + +;;;;; Pull-down menu +(easy-menu-define sly-menu sly-mode-map "SLY" + (let ((C '(sly-connected-p))) + `("SLY" + [ "Edit Definition..." sly-edit-definition ,C ] + [ "Return From Definition" sly-pop-find-definition-stack ,C ] + [ "Complete Symbol" sly-complete-symbol ,C ] + "--" + ("Evaluation" + [ "Eval Defun" sly-eval-defun ,C ] + [ "Eval Last Expression" sly-eval-last-expression ,C ] + [ "Eval And Pretty-Print" sly-pprint-eval-last-expression ,C ] + [ "Eval Region" sly-eval-region ,C ] + [ "Eval Region And Pretty-Print" sly-pprint-eval-region ,C ] + [ "Interactive Eval..." sly-interactive-eval ,C ] + [ "Edit Lisp Value..." sly-edit-value ,C ] + [ "Call Defun" sly-call-defun ,C ]) + ("Debugging" + [ "Inspect..." sly-inspect ,C ] + [ "Macroexpand Once..." sly-macroexpand-1 ,C ] + [ "Macroexpand All..." sly-macroexpand-all ,C ] + [ "Disassemble..." sly-disassemble-symbol ,C ]) + ("Compilation" + [ "Compile Defun" sly-compile-defun ,C ] + [ "Compile and Load File" sly-compile-and-load-file ,C ] + [ "Compile File" sly-compile-file ,C ] + [ "Compile Region" sly-compile-region ,C ] + "--" + [ "Next Note" sly-next-note t ] + [ "Previous Note" sly-previous-note t ] + [ "Remove Notes" sly-remove-notes t ] + [ "List notes" sly-show-compilation-log t ]) + ("Cross Reference" + [ "Who Calls..." sly-who-calls ,C ] + [ "Who References... " sly-who-references ,C ] + [ "Who Sets..." sly-who-sets ,C ] + [ "Who Binds..." sly-who-binds ,C ] + [ "Who Macroexpands..." sly-who-macroexpands ,C ] + [ "Who Specializes..." sly-who-specializes ,C ] + [ "List Callers..." sly-list-callers ,C ] + [ "List Callees..." sly-list-callees ,C ] + [ "Next Location" sly-next-location t ]) + ("Editing" + [ "Check Parens" check-parens t] + [ "Update Indentation" sly-update-indentation ,C]) + ("Documentation" + [ "Describe Symbol..." sly-describe-symbol ,C ] + [ "Lookup Documentation..." sly-documentation-lookup t ] + [ "Apropos..." sly-apropos ,C ] + [ "Apropos all..." sly-apropos-all ,C ] + [ "Apropos Package..." sly-apropos-package ,C ] + [ "Hyperspec..." sly-hyperspec-lookup t ]) + "--" + [ "Interrupt Command" sly-interrupt ,C ] + [ "Abort Async. Command" sly-quit ,C ]))) + +(easy-menu-define sly-sly-db-menu sly-db-mode-map "SLY-DB Menu" + (let ((C '(sly-connected-p))) + `("SLY-DB" + [ "Next Frame" sly-db-down t ] + [ "Previous Frame" sly-db-up t ] + [ "Toggle Frame Details" sly-db-toggle-details t ] + [ "Next Frame (Details)" sly-db-details-down t ] + [ "Previous Frame (Details)" sly-db-details-up t ] + "--" + [ "Eval Expression..." sly-interactive-eval ,C ] + [ "Eval in Frame..." sly-db-eval-in-frame ,C ] + [ "Eval in Frame (pretty print)..." sly-db-pprint-eval-in-frame ,C ] + [ "Inspect In Frame..." sly-db-inspect-in-frame ,C ] + [ "Inspect Condition Object" sly-db-inspect-condition ,C ] + "--" + [ "Restart Frame" sly-db-restart-frame ,C ] + [ "Return from Frame..." sly-db-return-from-frame ,C ] + ("Invoke Restart" + [ "Continue" sly-db-continue ,C ] + [ "Abort" sly-db-abort ,C ] + [ "Step" sly-db-step ,C ] + [ "Step next" sly-db-next ,C ] + [ "Step out" sly-db-out ,C ] + ) + "--" + [ "Quit (throw)" sly-db-quit ,C ] + [ "Break With Default Debugger" sly-db-break-with-default-debugger ,C ]))) + +(easy-menu-define sly-inspector-menu sly-inspector-mode-map + "Menu for the SLY Inspector" + (let ((C '(sly-connected-p))) + `("SLY-Inspector" + [ "Pop Inspectee" sly-inspector-pop ,C ] + [ "Next Inspectee" sly-inspector-next ,C ] + [ "Describe this Inspectee" sly-inspector-describe ,C ] + [ "Eval in context" sly-inspector-eval ,C ] + [ "Show history" sly-inspector-history ,C ] + [ "Reinspect" sly-inspector-reinspect ,C ] + [ "Fetch all parts" sly-inspector-fetch-all ,C ] + [ "Quit" sly-inspector-quit ,C ]))) + + +;;;; Utilities (no not Paul Graham style) + +;;; FIXME: this looks almost sly `sly-alistify', perhaps the two +;;; functions can be merged. +(defun sly-group-similar (similar-p list) + "Return the list of lists of 'similar' adjacent elements of LIST. +The function SIMILAR-P is used to test for similarity. +The order of the input list is preserved." + (if (null list) + nil + (let ((accumulator (list (list (car list))))) + (dolist (x (cdr list)) + (if (funcall similar-p x (caar accumulator)) + (push x (car accumulator)) + (push (list x) accumulator))) + (nreverse (mapcar #'nreverse accumulator))))) + +(defun sly-alistify (list key test) + "Partition the elements of LIST into an alist. +KEY extracts the key from an element and TEST is used to compare +keys." + (let ((alist '())) + (dolist (e list) + (let* ((k (funcall key e)) + (probe (cl-assoc k alist :test test))) + (if probe + (push e (cdr probe)) + (push (cons k (list e)) alist)))) + ;; Put them back in order. + (nreverse (mapc (lambda (ent) + (setcdr ent (nreverse (cdr ent)))) + alist)))) + +;;;;; Misc. + +(defun sly-length= (list n) + "Return (= (length LIST) N)." + (if (zerop n) + (null list) + (let ((tail (nthcdr (1- n) list))) + (and tail (null (cdr tail)))))) + +(defun sly-length> (seq n) + "Return (> (length SEQ) N)." + (cl-etypecase seq + (list (nthcdr n seq)) + (sequence (> (length seq) n)))) + +(defun sly-trim-whitespace (str) + "Chomp leading and tailing whitespace from STR." + ;; lited from http://www.emacswiki.org/emacs/ElispCookbook + (replace-regexp-in-string (rx (or (: bos (* (any " \t\n"))) + (: (* (any " \t\n")) eos))) + "" + str)) + +;;;;; Buffer related + +(defun sly-column-max () + (save-excursion + (goto-char (point-min)) + (cl-loop for column = (prog2 (end-of-line) (current-column) (forward-line)) + until (= (point) (point-max)) + maximizing column))) + +;;;;; CL symbols vs. Elisp symbols. + +(defun sly-cl-symbol-name (symbol) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match ":\\([^:]*\\)$" n) + (let ((symbol-part (match-string 1 n))) + (if (string-match "^|\\(.*\\)|$" symbol-part) + (match-string 1 symbol-part) + symbol-part)) + n))) + +(defun sly-cl-symbol-package (symbol &optional default) + (let ((n (if (stringp symbol) symbol (symbol-name symbol)))) + (if (string-match "^\\([^:]*\\):" n) + (match-string 1 n) + default))) + +(defun sly-qualify-cl-symbol-name (symbol-or-name) + "Return a package-qualified string for SYMBOL-OR-NAME. +If SYMBOL-OR-NAME doesn't already have a package prefix the +current package is used." + (let ((s (if (stringp symbol-or-name) + symbol-or-name + (symbol-name symbol-or-name)))) + (if (sly-cl-symbol-package s) + s + (format "%s::%s" + (let* ((package (sly-current-package))) + ;; package is a string like ":cl-user" + ;; or "CL-USER", or "\"CL-USER\"". + (if package + (sly--pretty-package-name package) + "CL-USER")) + (sly-cl-symbol-name s))))) + +;;;;; Moving, CL idiosyncracies aware (reader conditionals &c.) + +(defmacro sly-point-moves-p (&rest body) + "Execute BODY and return true if the current buffer's point moved." + (declare (indent 0)) + (let ((pointvar (cl-gensym "point-"))) + `(let ((,pointvar (point))) + (save-current-buffer ,@body) + (/= ,pointvar (point))))) + +(defun sly-forward-sexp (&optional count) + "Like `forward-sexp', but understands reader-conditionals (#- and #+), +and skips comments." + (dotimes (_i (or count 1)) + (sly-forward-cruft) + (forward-sexp))) + +(defconst sly-reader-conditionals-regexp + ;; #!+, #!- are SBCL specific reader-conditional syntax. + ;; We need this for the source files of SBCL itself. + (regexp-opt '("#+" "#-" "#!+" "#!-"))) + +(defsubst sly-forward-reader-conditional () + "Move past any reader conditional (#+ or #-) at point." + (when (looking-at sly-reader-conditionals-regexp) + (goto-char (match-end 0)) + (let* ((plus-conditional-p (eq (char-before) ?+)) + (result (sly-eval-feature-expression + (condition-case e + (read (current-buffer)) + (invalid-read-syntax + (signal 'sly-unknown-feature-expression (cdr e))))))) + (unless (if plus-conditional-p result (not result)) + ;; skip this sexp + (sly-forward-sexp))))) + +(defun sly-forward-cruft () + "Move forward over whitespace, comments, reader conditionals." + (while (sly-point-moves-p (skip-chars-forward " \t\n") + (forward-comment (buffer-size)) + (sly-forward-reader-conditional)))) + +(defun sly-keywordify (symbol) + "Make a keyword out of the symbol SYMBOL." + (let ((name (downcase (symbol-name symbol)))) + (intern (if (eq ?: (aref name 0)) + name + (concat ":" name))))) + +(put 'sly-incorrect-feature-expression + 'error-conditions '(sly-incorrect-feature-expression error)) + +(put 'sly-unknown-feature-expression + 'error-conditions '(sly-unknown-feature-expression + sly-incorrect-feature-expression + error)) + +;; FIXME: let it crash +;; FIXME: the (null (cdr l)) constraint is bogus +(defun sly-eval-feature-expression (e) + "Interpret a reader conditional expression." + (cond ((symbolp e) + (memq (sly-keywordify e) (sly-lisp-features))) + ((and (consp e) (symbolp (car e))) + (funcall (let ((head (sly-keywordify (car e)))) + (cl-case head + (:and #'cl-every) + (:or #'cl-some) + (:not + (let ((feature-expression e)) + (lambda (f l) + (cond ((null l) t) + ((null (cdr l)) (not (apply f l))) + (t (signal 'sly-incorrect-feature-expression + feature-expression)))))) + (t (signal 'sly-unknown-feature-expression head)))) + #'sly-eval-feature-expression + (cdr e))) + (t (signal 'sly-incorrect-feature-expression e)))) + +;;;;; Extracting Lisp forms from the buffer or user + +(defun sly-region-for-defun-at-point (&optional pos) + "Return a list (START END) for the positions of defun at POS. +POS defaults to point" + (save-excursion + (save-match-data + (goto-char (or pos (point))) + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (list (point) end))))) + +(defun sly-beginning-of-symbol () + "Move to the beginning of the CL-style symbol at point." + (while (re-search-backward "\\(\\sw\\|\\s_\\|\\s\\.\\|\\s\\\\|[#@|]\\)\\=" + (when (> (point) 2000) (- (point) 2000)) + t)) + (re-search-forward "\\=#[-+.<|]" nil t) + (when (and (eq (char-after) ?@) (eq (char-before) ?\,)) + (forward-char))) + +(defsubst sly-end-of-symbol () + "Move to the end of the CL-style symbol at point." + (re-search-forward "\\=\\(\\sw\\|\\s_\\|\\s\\.\\|#:\\|[@|]\\)*")) + +(put 'sly-symbol 'end-op 'sly-end-of-symbol) +(put 'sly-symbol 'beginning-op 'sly-beginning-of-symbol) + +(defun sly-symbol-start-pos () + "Return the starting position of the symbol under point. +The result is unspecified if there isn't a symbol under the point." + (save-excursion (sly-beginning-of-symbol) (point))) + +(defun sly-symbol-end-pos () + (save-excursion (sly-end-of-symbol) (point))) + +(defun sly-bounds-of-symbol-at-point () + "Return the bounds of the symbol around point. +The returned bounds are either nil or non-empty." + (let ((bounds (bounds-of-thing-at-point 'sly-symbol))) + (if (and bounds + (< (car bounds) + (cdr bounds))) + bounds))) + +(defun sly-symbol-at-point (&optional interactive) + "Return the name of the symbol at point, otherwise nil." + ;; (thing-at-point 'symbol) returns "" in empty buffers + (let ((bounds (sly-bounds-of-symbol-at-point))) + (when bounds + (let ((beg (car bounds)) (end (cdr bounds))) + (when interactive (sly-flash-region beg end)) + (buffer-substring-no-properties beg end))))) + +(defun sly-bounds-of-sexp-at-point (&optional interactive) + "Return the bounds sexp near point as a pair (or nil). +With non-nil INTERACTIVE, error if can't find such a thing." + (or (sly-bounds-of-symbol-at-point) + (and (equal (char-after) ?\() + (member (char-before) '(?\' ?\, ?\@)) + ;; hide stuff before ( to avoid quirks with '( etc. + (save-restriction + (narrow-to-region (point) (point-max)) + (bounds-of-thing-at-point 'sexp))) + (bounds-of-thing-at-point 'sexp) + (and (save-excursion + (and (ignore-errors + (backward-sexp 1) + t) + (bounds-of-thing-at-point 'sexp)))) + (when interactive + (user-error "No sexp near point")))) + +(cl-defun sly-sexp-at-point (&optional interactive stringp (errorp t)) + "Return the sexp at point as a string, otherwise nil. +With non-nil INTERACTIVE, flash the region and also error if no +sexp can be found, unless ERRORP, which defaults to t, is passed +as nil. With non-nil STRINGP, only look for strings" + (catch 'return + (let ((bounds (sly-bounds-of-sexp-at-point (and interactive + errorp)))) + (when bounds + (when (and stringp + (not (eq (syntax-class (syntax-after (car bounds))) + (char-syntax ?\")))) + (if (and interactive + errorp) + (user-error "No string at point") + (throw 'return nil))) + (when interactive + (sly-flash-region (car bounds) (cdr bounds))) + (buffer-substring-no-properties (car bounds) + (cdr bounds)))))) + +(defun sly-string-at-point (&optional interactive) + "Returns the string near point as a string, otherwise nil. +With non-nil INTERACTIVE, flash the region and error if no string +can be found." + (sly-sexp-at-point interactive 'stringp)) + +(defun sly-input-complete-p (start end) + "Return t if the region from START to END contains a complete sexp." + (save-excursion + (goto-char start) + (cond ((looking-at "\\s *['`#]?[(\"]") + (ignore-errors + (save-restriction + (narrow-to-region start end) + ;; Keep stepping over blanks and sexps until the end of + ;; buffer is reached or an error occurs. Tolerate extra + ;; close parens. + (cl-loop do (skip-chars-forward " \t\r\n)") + until (eobp) + do (forward-sexp)) + t))) + (t t)))) + + +;;;; sly.el in pretty colors + +(cl-loop for sym in (list 'sly-def-connection-var + 'sly-define-channel-type + 'sly-define-channel-method + 'define-sly-contrib) + for regexp = (format "(\\(%S\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" + sym) + do (font-lock-add-keywords + 'emacs-lisp-mode + `((,regexp (1 font-lock-keyword-face) + (2 font-lock-variable-name-face))))) + +;;;; Finishing up + +(defun sly--byte-compile (symbol) + (require 'bytecomp) ;; tricky interaction between autoload and let. + (let ((byte-compile-warnings '())) + (byte-compile symbol))) + +(defun sly-byte-compile-hotspots (syms) + (mapc (lambda (sym) + (cond ((fboundp sym) + (unless (or (byte-code-function-p (symbol-function sym)) + (subrp (symbol-function sym))) + (sly--byte-compile sym))) + (t (error "%S is not fbound" sym)))) + syms)) + +(sly-byte-compile-hotspots + '(sly-alistify + sly-log-event + sly--events-buffer + sly-process-available-input + sly-dispatch-event + sly-net-filter + sly-net-have-input-p + sly-net-decode-length + sly-net-read + sly-print-apropos + sly-insert-propertized + sly-beginning-of-symbol + sly-end-of-symbol + sly-eval-feature-expression + sly-forward-sexp + sly-forward-cruft + sly-forward-reader-conditional)) + +;;;###autoload +(add-hook 'lisp-mode-hook 'sly-editing-mode) + +(defcustom sly-replace-slime 'ask + "Specify whether SLY should replace SLIME at load time. + +This only has an effect if parts of SLIME components are already +loaded (e.g. in `lisp-mode-hook'). + +If `ask' prompt the user at load-time; if nil never replace; if t or +other non-nil value to unconditionally replace SLIME." + :type '(choice (const :tag "Ask user" ask) + (const :tag "Do not replace SLIME" nil) + (const :tag "Do replace SLIME" t))) + +(cond + ((or (not (memq 'slime-lisp-mode-hook lisp-mode-hook)) + noninteractive + (prog1 + (if (eq sly-replace-slime 'ask) + (y-or-n-p "[sly] SLIME detected in `lisp-mode-hook', causes keybinding conflicts. Remove it for this Emacs session?") + sly-replace-slime) + (warn "To restore SLIME in this session, customize `lisp-mode-hook' +and replace `sly-editing-mode' with `slime-lisp-mode-hook'."))) + (remove-hook 'lisp-mode-hook 'slime-lisp-mode-hook) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (eq major-mode 'lisp-mode) + (unless sly-editing-mode (sly-editing-mode 1)) + (ignore-errors (and (featurep 'slime) (funcall 'slime-mode -1))))))) + (t + (warn + "`sly.el' loaded OK. To use SLY, customize `lisp-mode-hook' and remove `slime-lisp-mode-hook'."))) + +(provide 'sly) + +;;; sly.el ends here +;; Local Variables: +;; coding: utf-8 +;; End: blob - /dev/null blob + 29a708c9d2e2320f3f1c8f90ea99fbcdbc0a350d (mode 644) Binary files /dev/null and elpa/sly-20250522.2241/sly.info differ blob - /dev/null blob + 431f9cb8ef71f23ec3f3167d2c890d4a80ac9794 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/abcl.lisp @@ -0,0 +1,1531 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*- +;;; +;;; slynk-abcl.lisp --- Armedbear CL specific code for SLY. +;;; +;;; Adapted from slynk-acl.lisp, Andras Simon, 2004 +;;; New work by Alan Ruttenberg, 2016-7 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage slynk/abcl + (:use cl slynk-backend) + (:import-from :java + #:jcall #:jstatic + #:jmethod + #:jfield + #:jconstructor + #:jnew-array #:jarray-length #:jarray-ref #:jnew-array-from-array + #:jclass #:jnew #:java-object + ;; be conservative and add any import java functions only for later lisps + #+#.(slynk-backend:with-symbol 'jfield-name 'java) #:jfield-name + #+#.(slynk-backend:with-symbol 'jinstance-of-p 'java) #:jinstance-of-p + #+#.(slynk-backend:with-symbol 'jclass-superclass 'java) #:jclass-superclass + #+#.(slynk-backend:with-symbol 'jclass-interfaces 'java) #:jclass-interfaces + #+#.(slynk-backend:with-symbol 'java-exception 'java) #:java-exception + #+#.(slynk-backend:with-symbol 'jobject-class 'java) #:jobject-class + #+#.(slynk-backend:with-symbol 'jclass-name 'java) #:jclass-name + #+#.(slynk-backend:with-symbol 'java-object-p 'java) #:java-object-p)) + +(in-package slynk/abcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :collect) ;just so that it doesn't spoil the flying letters + (require :pprint) + (require :gray-streams) + (require :abcl-contrib) + + ;;; Probe and load ABCL-INTROSPECT pushing to *FEATURES* on success + ;;; allowing us to conditionalize usage via `#+abcl-introspect` forms. + (when (ignore-errors (and + (fboundp '(setf sys::function-plist)) + (progn + (require :abcl-introspect) + (find "ABCL-INTROSPECT" *modules* :test + 'equal)))) + (pushnew :abcl-introspect *features*))) + +(defimplementation gray-package-name () + "GRAY-STREAMS") + +;; FIXME: switch to shared Gray stream implementation when the +;; architecture for booting streams allows us to replace the Java-side +;; implementation of a Sly{Input,Output}Stream.java classes are +;; subsumed . +(progn + (defimplementation make-output-stream (write-string) + (ext:make-slime-output-stream write-string)) + + (defimplementation make-input-stream (read-string) + (ext:make-slime-input-stream read-string + (make-synonym-stream '*standard-output*)))) + +;; A hack to call functions from packages that don't exist when this code is loaded. +;; An FLET is used to make sure all the uses of it are contained in wrapper functions +;; so this hack can be easily swapped out later. +(flet ((evil-hack (function &rest args) (apply (read-from-string function) args))) + (defun %%lcons (car cdr) + (evil-hack "slynk::%lcons" car (lambda () cdr))) + + (defun %%lookup-class-name (&rest args) + (evil-hack "jss::lookup-class-name" args)) + + (defun %%ed-in-emacs (what) + (evil-hack "slynk:ed-in-emacs" what)) + + (defun %%method-for-inspect-value (method) + ;; Note that this one is in slynk-fancy-inspector + (evil-hack "slynk::method-for-inspect-value" method)) + + (defun %%abbrev-doc (doc) + (evil-hack "slynk::abbrev-doc" doc))) + + +;;; Have CL:INSPECT use SLY +;;; +;;; Since Slynk may also be run in a server not running under Emacs +;;; and potentially with other REPLs, we export a functional toggle +;;; for the user to call after loading these definitions. +(defun enable-cl-inspect-in-emacs () + (slynk-backend:wrap 'cl:inspect :use-sly + :replace (slynk-backend:find-symbol2 "slynk:inspect-in-emacs"))) + +;; ??? repair bare print object so inspector titles show java class +(defun %print-unreadable-object-java-too (object stream type identity body) + (setf stream (sys::out-synonym-of stream)) + (when *print-readably* + (error 'print-not-readable :object object)) + (format stream "#<") + (when type + (if (java-object-p object) + ;; Special handling for java objects + (if (jinstance-of-p object "java.lang.Class") + (progn + (write-string "jclass " stream) + (format stream "~a" (jclass-name object))) + (format stream "~a" (jclass-name (jobject-class object)))) + ;; usual handling + (format stream "~S" (type-of object))) + (format stream " ")) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (format stream " ")) + (format stream "{~X}" (sys::identity-hash-code object))) + (format stream ">") + nil) + +;;; TODO: move such invocations out of toplevel? +(eval-when (:load-toplevel) + (unless (get 'sys::%print-unreadable-object 'slynk-backend::sly-wrap) + (wrap 'sys::%print-unreadable-object :more-informative :replace '%print-unreadable-object-java-too))) + +(defimplementation call-with-compilation-hooks (function) + (funcall function)) + + +;;;; MOP + +;;dummies and definition + +(defclass standard-slot-definition ()()) + +(defun slot-definition-documentation (slot) + #-abcl-introspect + (declare (ignore slot)) + #+abcl-introspect + (documentation slot 't)) + +(defun slot-definition-type (slot) + (declare (ignore slot)) + t) + +(defun class-prototype (class) + (declare (ignore class)) + nil) + +(defun generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun specializer-direct-methods (spec) + (mop:class-direct-methods spec)) + +(defun slot-definition-name (slot) + (mop:slot-definition-name slot)) + +(defun class-slots (class) + (mop:class-slots class)) + +(defun method-generic-function (method) + (mop:method-generic-function method)) + +(defun method-function (method) + (mop:method-function method)) + +(defun slot-boundp-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-boundp object (slot-definition-name slotdef))) + +(defun slot-value-using-class (class object slotdef) + (declare (ignore class)) + (system::slot-value object (slot-definition-name slotdef))) + +(defun (setf slot-value-using-class) (new class object slotdef ) + (declare (ignore class)) + (mop::%set-slot-value object (slot-definition-name slotdef) new)) + +(import-to-slynk-mop + '( ;; classes + cl:standard-generic-function + standard-slot-definition ;;dummy + cl:method + cl:standard-class + #+#.(slynk-backend:with-symbol + 'compute-applicable-methods-using-classes 'mop) + mop:compute-applicable-methods-using-classes + ;; standard-class readers + mop:class-default-initargs + mop:class-direct-default-initargs + mop:class-direct-slots + mop:class-direct-subclasses + mop:class-direct-superclasses + mop:eql-specializer + mop:class-finalized-p + mop:finalize-inheritance + cl:class-name + mop:class-precedence-list + class-prototype ;;dummy + class-slots + specializer-direct-methods + ;; eql-specializer accessors + mop::eql-specializer-object + ;; generic function readers + mop:generic-function-argument-precedence-order + generic-function-declarations ;;dummy + mop:generic-function-lambda-list + mop:generic-function-methods + mop:generic-function-method-class + mop:generic-function-method-combination + mop:generic-function-name + ;; method readers + method-generic-function + method-function + mop:method-lambda-list + mop:method-specializers + mop:method-qualifiers + ;; slot readers + mop:slot-definition-allocation + slot-definition-documentation ;;dummy + mop:slot-definition-initargs + mop:slot-definition-initform + mop:slot-definition-initfunction + slot-definition-name + slot-definition-type ;;dummy + mop:slot-definition-readers + mop:slot-definition-writers + slot-boundp-using-class + slot-value-using-class + set-slot-value-using-class + #+#.(slynk-backend:with-symbol + 'slot-makunbound-using-class 'mop) + mop:slot-makunbound-using-class)) + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ext:make-server-socket port)) + +(defimplementation local-port (socket) + (jcall (jmethod "java.net.ServerSocket" "getLocalPort") socket)) + +(defimplementation close-socket (socket) + (ext:server-socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (ext:get-socket-stream (ext:socket-accept socket) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +;;;; UTF8 + +;; faster please! +(defimplementation string-to-utf8 (s) + (jbytes-to-octets + (java:jcall + (java:jmethod "java.lang.String" "getBytes" "java.lang.String") + s + "UTF8"))) + +(defimplementation utf8-to-string (u) + (java:jnew + (java:jconstructor "org.armedbear.lisp.SimpleString" + "java.lang.String") + (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String") + (octets-to-jbytes u) + "UTF8"))) + +(defun octets-to-jbytes (octets) + (declare (type octets (simple-array (unsigned-byte 8) (*)))) + (let* ((len (length octets)) + (bytes (java:jnew-array "byte" len))) + (loop for byte across octets + for i from 0 + do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte" + "java.lang.Object" "int" "byte") + "java.lang.reflect.Array" + bytes i byte)) + bytes)) + +(defun jbytes-to-octets (jbytes) + (let* ((len (java:jarray-length jbytes)) + (octets (make-array len :element-type '(unsigned-byte 8)))) + (loop for i from 0 below len + for jbyte = (java:jarray-ref jbytes i) + do (setf (aref octets i) jbyte)) + octets)) + +;;;; External formats + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1") + ((:iso-8859-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + (:utf-8 "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + (:euc-jp "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + (:us-ascii "us-ascii") + ((:us-ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;;; Unix signals + +(defimplementation getpid () + (if (fboundp 'ext::get-pid) + (ext::get-pid) ;;; Introduced with abcl-1.5.0 + (handler-case + (let* ((runtime + (java:jstatic "getRuntime" "java.lang.Runtime")) + (command + (java:jnew-array-from-array + "java.lang.String" #("sh" "-c" "echo $PPID"))) + (runtime-exec-jmethod + ;; Complicated because java.lang.Runtime.exec() is + ;; overloaded on a non-primitive type (array of + ;; java.lang.String), so we have to use the actual + ;; parameter instance to get java.lang.Class + (java:jmethod "java.lang.Runtime" "exec" + (java:jcall + (java:jmethod "java.lang.Object" "getClass") + command))) + (process + (java:jcall runtime-exec-jmethod runtime command)) + (output + (java:jcall (java:jmethod "java.lang.Process" "getInputStream") + process))) + (java:jcall (java:jmethod "java.lang.Process" "waitFor") + process) + (loop :with b :do + (setq b + (java:jcall (java:jmethod "java.io.InputStream" "read") + output)) + :until (member b '(-1 #x0a)) ; Either EOF or LF + :collecting (code-char b) :into result + :finally (return + (parse-integer (coerce result 'string))))) + (t () 0)))) + +(defimplementation lisp-implementation-type-name () + "armedbear") + +(defimplementation set-default-directory (directory) + (let ((dir (sys::probe-directory directory))) + (when dir (setf *default-pathname-defaults* dir)) + (namestring dir))) + + +;;;; Misc + +(defimplementation arglist (fun) + (cond ((symbolp fun) + (multiple-value-bind (arglist present) + (sys::arglist fun) + (when (and (not present) + (fboundp fun) + (typep (symbol-function fun) + 'standard-generic-function)) + (setq arglist + (mop::generic-function-lambda-list (symbol-function fun)) + present + t)) + (if present arglist :not-available))) + (t :not-available))) + +(defimplementation function-name (function) + (if (fboundp 'sys::any-function-name) + ;; abcl-1.5.0 + (sys::any-function-name function) + ;; pre abcl-1.5.0 + (nth-value 2 (function-lambda-expression function)))) + +(defimplementation macroexpand-all (form &optional env) + (ext:macroexpand-all form env)) + +(defimplementation collect-macro-forms (form &optional env) + ;; Currently detects only normal macros, not compiler macros. + (declare (ignore env)) + (with-collected-macro-forms (macro-forms) + (handler-bind ((warning #'muffle-warning)) + (ignore-errors + (compile nil `(lambda () ,(macroexpand-all form env))))) + (values macro-forms nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + ((:variable :macro) + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;;; Debugger + +;; Copied from slynk-sbcl.lisp. +#+abcl-introspect +(defvar sys::*caught-frames*) +;; +;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*, +;; so we have to make sure that the latter gets run when it was +;; established locally by a user (i.e. changed meanwhile.) +(defun make-invoke-debugger-hook (hook) + (lambda (condition old-hook) + (prog1 (let (#+abcl-introspect + (sys::*caught-frames* nil)) + ;; the next might be the right thing for earlier lisps but I don't know + ;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on abcl-1.4 and earlier + (let (#+abcl-introspect + (sys::*saved-backtrace* + (if (fboundp 'sys::new-backtrace) + (sys::new-backtrace condition) + (sys::backtrace)))) + (if *debugger-hook* + (funcall *debugger-hook* condition old-hook) + (funcall hook condition old-hook))))))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defvar *sldb-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((magic-token (intern "SLYNK-DEBUGGER-HOOK" 'slynk)) + (*sldb-topframe* + (or + (second (member magic-token + #+abcl-introspect sys::*saved-backtrace* + #-abcl-introspect (sys:backtrace) + :key (lambda (frame) + (first (sys:frame-to-list frame))))) + (car sys::*saved-backtrace*))) + #+#.(slynk-backend:with-symbol *debug-condition* 'ext) + (ext::*debug-condition* + (slynk-backend:find-symbol2 "slynk::*slynk-debugger-condition*"))) + (funcall debugger-loop-fn))) + +(defun backtrace (start end) + "A backtrace without initial SLYNK frames." + (let ((backtrace + #+abcl-introspect sys::*saved-backtrace* + #-abcl-introspect (sys:backtrace))) + (subseq (or (member *sldb-topframe* backtrace) backtrace) start end))) + +(defun nth-frame (index) + (nth index (backtrace 0 nil))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (backtrace start end))) + +;; Don't count on JSS being loaded, but if it is then there's some more stuff we can do ++#+#.(slynk-backend:with-symbol 'invoke-restargs 'jss) +(defun jss-p () + (and (member "JSS" *modules* :test 'string=) (intern "INVOKE-RESTARGS" "JSS"))) + ++#+#.(slynk-backend:with-symbol 'invoke-restargs 'jss) +(defun matches-jss-call (form) + (flet ((gensymp (s) (and (symbolp s) (null (symbol-package s)))) + (invokep (s) (and (symbolp s) (eq s (jss-p))))) + (let ((method + (slynk-match::select-match + form + (((LAMBDA ((#'gensymp a) &REST (#'gensymp b)) + ((#'invokep fun) (#'stringp c) (#'gensymp d) (#'gensymp e) . args)) . args) '=> c) + (other nil)))) + method))) + +#-abcl-introspect +(defimplementation print-frame (frame stream) + (write-string (sys:frame-to-string frame) + stream)) + +;; Use princ cs write-string for lisp frames as it respects (print-object (function t)) +;; Rewrite jss expansions to their unexpanded state +;; Show java exception frames up to where a java exception happened with a "!" +;; Check if a java class corresponds to a lisp function and tell us if to +(defvar *debugger-package* (find-package 'cl-user)) + +#+abcl-introspect +(defimplementation print-frame (frame stream) + ;; make clear which functions aren't Common Lisp. Otherwise uses + ;; default package, which is invisible + (let ((*package* (or *debugger-package* *package*))) + (if (typep frame 'sys::lisp-stack-frame) + (if (not (jss-p)) + (princ (system:frame-to-list frame) stream) + ;; rewrite jss forms as they would be written + (let ((form (system:frame-to-list frame))) + (if (eq (car form) (jss-p)) + (format stream "(#~s ~{~s~^~})" (second form) (list* (third form) (fourth form))) + (loop initially (write-char #\( stream) + for (el . rest) on form + for method = (slynk/abcl::matches-jss-call el) + do + (cond (method + (format stream "(#~s ~{~s~^~})" method (cdr el))) + (t + (prin1 el stream))) + (unless (null rest) (write-char #\space stream)) + finally (write-char #\) stream))))) + (let ((classname (getf (sys:frame-to-list frame) :class))) + (if (and (fboundp 'sys::javaframe) + (member (sys::javaframe frame) sys::*caught-frames* :test 'equal)) + (write-string "! " stream)) + (write-string (sys:frame-to-string frame) stream) + (if (and classname (sys::java-class-lisp-function classname)) + (format stream " = ~a" (sys::java-class-lisp-function classname))))))) + +;;; Machinery for DEFIMPLEMENTATION +;;; FIXME can't seem to use FLET forms with DEFIMPLEMENTATION --ME 20150403 +(defun nth-frame-list (index) + (jcall "toLispList" (nth-frame index))) + +(defun match-lambda (operator values) + (jvm::match-lambda-list + (multiple-value-list + (jvm::parse-lambda-list (ext:arglist operator))) + values)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME + (when (typep frame 'sys::lisp-stack-frame) + (loop + :for id :upfrom 0 + :with frame = (nth-frame-list index) + :with operator = (first frame) + :with values = (rest frame) + :with arglist = (if (and operator (consp values) (not (null values))) + (handler-case (match-lambda operator values) + (jvm::lambda-list-mismatch (e) (declare(ignore e)) + :lambda-list-mismatch)) + :not-available) + :for value :in values + :collecting (list + :name (if (not (keywordp arglist)) + (first (nth id arglist)) + (format nil "arg~A" id)) + :id id + :value value))))) + +(defimplementation frame-var-value (index id) + (elt (rest (jcall "toLispList" (nth-frame index))) id)) + +#+abcl-introspect +(defimplementation disassemble-frame (index) + (sys::disassemble (frame-function (nth-frame index)))) + +(defun frame-function (frame) + (let ((list (sys::frame-to-list frame))) + (cond + ((keywordp (car list)) + (find (getf list :method) + (jcall "getDeclaredMethods" (jclass (getf list :class))) + :key (lambda(e)(jcall "getName" e)) :test 'equal)) + (t (car list) )))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (or (source-location (nth-frame index)) + `(:error ,(format nil "No source for frame: ~a" frame))))) + + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defvar *abcl-signaled-conditions*) + +(defun handle-compiler-warning (condition) + (let ((loc (when (and jvm::*compile-file-pathname* + system::*source-position*) + (cons jvm::*compile-file-pathname* system::*source-position*)))) + ;; filter condition signaled more than once. + (unless (member condition *abcl-signaled-conditions*) + (push condition *abcl-signaled-conditions*) + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (format nil "~A" condition) + :location (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0))) + (loc + (destructuring-bind (file . pos) loc + (make-location + (list :file (namestring (truename file))) + (list :position (1+ pos))))) + (t + (make-location + (list :file (namestring *compile-filename*)) + (list :position 1)))))))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (fn warn fail) + (compile-file input-file :output-file output-file) + (values fn warn + (and fn load-p + (not (load fn))))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (let ((jvm::*resignal-compiler-warnings* t) + (*abcl-signaled-conditions* nil)) + (handler-bind ((warning #'handle-compiler-warning)) + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string) + (sys::*source* (make-pathname :device "emacs-buffer" :name buffer)) + (sys::*source-position* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; source location and users of it + +(defgeneric source-location (object)) + +;; try to find some kind of source for internals +#+abcl-introspect +(defun implementation-source-location (arg) + (let ((function (cond ((functionp arg) + arg) + ((and (symbolp arg) (fboundp arg)) + (or (symbol-function arg) (macro-function arg)))))) + (when (typep function 'generic-function) + (setf function (mop::funcallable-instance-function function))) + ;; functions are execute methods of class + (when (or (functionp function) (special-operator-p arg)) + (let ((fclass (jcall "getClass" function))) + (let ((classname (jcall "getName" fclass))) + (destructuring-bind (class local) + (if (find #\$ classname) + (split-string classname "\\$") + (list classname (jcall "replaceFirst" classname "([^.]*\\.)*" ""))) + (unless (member local '("MacroObject" "CompiledClosure" "Closure") :test 'equal) + ;; look for java source + (let* ((partial-path (substitute #\/ #\. class)) + (java-path (concatenate 'string partial-path ".java")) + (found-in-source-path (find-file-in-path java-path *source-path*))) + ;; snippet for finding the internal class within the file + (if found-in-source-path + `((:primitive ,local) + (:location ,found-in-source-path + (:line 0) + (:snippet ,(format nil "class ~a" local)))) + ;; if not, look for the class file, and hope that + ;; emacs is configured to disassemble class entries + ;; in jars. + + ;; Alan uses jdc.el + ;; + ;; with jad + ;; Also (setq sys::*disassembler* "jad -a -p") + (let ((class-in-source-path + (find-file-in-path (concatenate 'string partial-path ".class") *source-path*))) + ;; no snippet, since internal class is in its own file + (when class-in-source-path + `(:primitive (:location ,class-in-source-path (:line 0) nil))))))))))))) + +#+abcl-introspect +(defun get-declared-field (class fieldname) + (find fieldname (jcall "getDeclaredFields" class) :key 'jfield-name :test 'equal)) + +#+abcl-introspect +(defun symbol-defined-in-java (symbol) + (loop with internal-name1 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "") "-" "_") + with internal-name2 = (jcall "replaceAll" (jcall "replaceAll" (string symbol) "\\*" "_") "-" "_") + for class in + (load-time-value (mapcar + 'jclass + '("org.armedbear.lisp.Package" + "org.armedbear.lisp.Symbol" + "org.armedbear.lisp.Debug" + "org.armedbear.lisp.Extensions" + "org.armedbear.lisp.JavaObject" + "org.armedbear.lisp.Lisp" + "org.armedbear.lisp.Pathname" + "org.armedbear.lisp.Site"))) + thereis + (or (get-declared-field class internal-name1) + (get-declared-field class internal-name2)))) + +#+abcl-introspect +(defun maybe-implementation-variable (s) + (let ((field (symbol-defined-in-java s))) + (and field + (let ((class (jcall "getName" (jcall "getDeclaringClass" field)))) + (let* ((partial-path (substitute #\/ #\. class)) + (java-path (concatenate 'string partial-path ".java")) + (found-in-source-path (find-file-in-path java-path *source-path*))) + (when found-in-source-path + `(symbol (:location ,found-in-source-path (:line 0) + (:snippet ,(format nil "~s" (string s))))))))))) + +#+abcl-introspect +(defun if-we-have-to-choose-one-choose-the-function (sources) + (or (loop for spec in sources + for (dspec) = spec + when (and (consp dspec) (eq (car dspec) :function)) + when (and (consp dspec) (member (car dspec) '(:slynk-implementation :function))) + do (return-from if-we-have-to-choose-one-choose-the-function spec)) + (car sources))) + +(defmethod source-location ((symbol symbol)) + (or #+abcl-introspect + (let ((maybe (if-we-have-to-choose-one-choose-the-function (get symbol 'sys::source)))) + (and maybe (second (sly-location-from-source-annotation symbol maybe)))) + ;; This below should be obsolete - it uses the old sys:%source + ;; leave it here for now just in case + (and (pathnamep (ext:source-pathname symbol)) + (let ((pos (ext:source-file-position symbol)) + (path (namestring (ext:source-pathname symbol)))) + ; boot.lisp gets recorded wrong + (when (equal path "boot.lisp") + (setq path (second (find-file-in-path "org/armedbear/lisp/boot.lisp" *source-path*)))) + (cond ((ext:pathname-jar-p path) + `(:location + ;; strip off "jar:file:" = 9 characters + (:zip ,@(split-string (subseq path (length "jar:file:")) "!/")) + ;; pos never seems right. Use function name. + (:function-name ,(string symbol)) + (:align t))) + ((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer") + ;; conspire with slynk-compile-string to keep the buffer + ;; name in a pathname whose device is "emacs-buffer". + `(:location + (:buffer ,(pathname-name (ext:source-pathname symbol))) + (:function-name ,(string symbol)) + (:align t))) + (t + `(:location + (:file ,path) + ,(if pos + (list :position (1+ pos)) + (list :function-name (string symbol))) + (:align t)))))) + #+abcl-introspect + (second (implementation-source-location symbol)))) + +(defmethod source-location ((frame sys::java-stack-frame)) + (destructuring-bind (&key class method file line) (sys:frame-to-list frame) + (declare (ignore method)) + (let ((file (or (find-file-in-path file *source-path*) + (let ((f (format nil "~{~a/~}~a" + (butlast (split-string class "\\.")) + file))) + (find-file-in-path f *source-path*))))) + (and file + `(:location ,file (:line ,line) ()))))) + +(defmethod source-location ((frame sys::lisp-stack-frame)) + (destructuring-bind (operator &rest args) (sys:frame-to-list frame) + (declare (ignore args)) + (etypecase operator + (function (source-location operator)) + (list nil) + (symbol (source-location operator))))) + +(defmethod source-location ((fun function)) + (if #+abcl-introspect + (sys::local-function-p fun) + #-abcl-introspect + nil + (source-location (sys::local-function-owner fun)) + (let ((name (function-name fun))) + (and name (source-location name))))) + +(defmethod source-location ((method method)) + #+abcl-introspect + (let ((found + (find `(:method ,@(sys::method-spec-list method)) + (get (function-name method) 'sys::source) + :key 'car :test 'equalp))) + (and found (second (sly-location-from-source-annotation (function-name method) found)))) + #-abcl-introspect + (let ((name (function-name fun))) + (and name (source-location name)))) + +(defun system-property (name) + (jstatic "getProperty" "java.lang.System" name)) + +(defun pathname-parent (pathname) + (make-pathname :directory (butlast (pathname-directory pathname)))) + +(defun pathname-absolute-p (pathname) + (eq (car (pathname-directory pathname)) ':absolute)) + +(defun split-string (string regexp) + (coerce + (jcall (jmethod "java.lang.String" "split" "java.lang.String") + string regexp) + 'list)) + +(defun path-separator () + (jfield "java.io.File" "pathSeparator")) + +(defun search-path-property (prop-name) + (let ((string (system-property prop-name))) + (and string + (remove nil + (mapcar #'truename + (split-string string (path-separator))))))) + +(defun jdk-source-path () + (let* ((jre-home (truename (system-property "java.home"))) + (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) + (truename (probe-file src-zip))) + (and truename (list truename)))) + +(defun class-path () + (append (search-path-property "java.class.path") + (search-path-property "sun.boot.class.path"))) + +(defvar *source-path* + (remove nil + (append (search-path-property "user.dir") + (jdk-source-path) + ;; include lib jar files. contrib has lisp code. Would be good to build abcl.jar with source code as well + #+abcl-introspect + (list (sys::find-system-jar) + (sys::find-contrib-jar)))) + ;; you should tell sly where the abcl sources are. In .slynk.lisp I have: + ;; (push (probe-file "/Users/alanr/repos/abcl/src/") *SOURCE-PATH*) +"List of directories to search for source files.") + +(defun zipfile-contains-p (zipfile-name entry-name) + (let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile" + "java.lang.String") + zipfile-name))) + (jcall + (jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") + zipfile entry-name))) + +;; Try to find FILENAME in PATH. If found, return a file spec as +;; needed by Emacs. We also look in zip files. +(defun find-file-in-path (filename path) + (labels ((try (dir) + (cond ((not (pathname-type dir)) + (let ((f (probe-file (merge-pathnames filename dir)))) + (and f `(:file ,(namestring f))))) + ((member (pathname-type dir) '("zip" "jar") :test 'equal) + (try-zip dir)) + (t (error "strange path element: ~s" path)))) + (try-zip (zip) + (let* ((zipfile-name (namestring (truename zip)))) + (and (zipfile-contains-p zipfile-name filename) + `(#+abcl-introspect + :zip + #-abcl-introspect + :dir + ,zipfile-name ,filename))))) + (cond ((pathname-absolute-p filename) (probe-file filename)) + (t + (loop for dir in path + if (try dir) return it))))) + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to Sly-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (or (if (and (consp type) (getf *definition-types* (car type))) + `(,(getf *definition-types* (car type)) ,(second type) ,@(third type) ,@(cdddr type)) + (getf *definition-types* type)) + type)) + +(defun stringify-method-specs (type) + "return a (:method ..) location for sly" + (let ((*print-case* :downcase)) + (flet ((p (a) (princ-to-string a))) + (destructuring-bind (name qualifiers specializers) (cdr type) + `(,(car type) ,(p name) ,(mapcar #'p specializers) ,@(mapcar #'p qualifiers)))))) + +;; for abcl source, check if it is still there, and if not, look in abcl jar instead +(defun maybe-redirect-to-jar (path) + (setq path (namestring path)) + (if (probe-file path) + path + (if (search "/org/armedbear/lisp" path :test 'string=) + (let ((jarpath (format nil "jar:file:~a!~a" (namestring (sys::find-system-jar)) + (subseq path (search "/org/armedbear/lisp" path))))) + (if (probe-file jarpath) + jarpath + path)) + path))) + +#-abcl-introspect +(defimplementation find-definitions (symbol) + (ext:resolve symbol) + (let ((srcloc (source-location symbol))) + (and srcloc `((,symbol ,srcloc))))) + +#+abcl-introspect +(defimplementation find-definitions (symbol) + (when (stringp symbol) + ;; allow a string to be passed. If it is package prefixed, remove the prefix + (setq symbol (intern (string-upcase + (subseq symbol (1+ (or (position #\: symbol :from-end t) -1)))) + 'keyword))) + (let ((sources nil) + (implementation-variables nil) + (implementation-functions nil)) + (loop for package in (list-all-packages) + for sym = (find-symbol (string symbol) package) + when (and sym (equal (symbol-package sym) package)) + do + (when (sys::autoloadp symbol) + (sys::resolve symbol)) + (let ((source (or (get sym 'ext::source) (get sym 'sys::source))) + (i-var (maybe-implementation-variable sym)) + (i-fun (implementation-source-location sym))) + (when source + (setq sources (append sources (or (get sym 'ext::source) (get sym 'sys::source))))) + (when i-var + (push i-var implementation-variables)) + (when i-fun + (push i-fun implementation-functions)))) + (setq sources (remove-duplicates sources :test 'equalp)) + (append (remove-duplicates implementation-functions :test 'equalp) + (mapcar (lambda(s) (sly-location-from-source-annotation symbol s)) sources) + (remove-duplicates implementation-variables :test 'equalp)))) + +(defun sly-location-from-source-annotation (sym it) + (destructuring-bind (what path pos) it + + (let* ((isfunction + ;; all of these are (defxxx forms, which is what :function locations look for in sly + (and (consp what) (member (car what) + '(:function :generic-function :macro :class :compiler-macro + :type :constant :variable :package :structure :condition)))) + (ismethod (and (consp what) (eq (car what) :method))) + ( (cond (isfunction (list :function-name (princ-to-string (second what)))) + (ismethod (stringify-method-specs what)) + (t (list :position (1+ (or pos 0)))))) + + (path2 (if (eq path :top-level) + ;; this is bogus - figure out some way to guess which is the repl associated with :toplevel + ;; or get rid of this + "emacs-buffer:*sly-repl*" + (maybe-redirect-to-jar path)))) + (when (atom what) + (setq what (list what sym))) + (list (definition-specifier what) + (if (ext:pathname-jar-p path2) + `(:location + (:zip ,@(split-string (subseq path2 (length "jar:file:")) "!/")) + ;; pos never seems right. Use function name. + , + (:align t)) + ;; conspire with slynk-compile-string to keep the + ;; buffer name in a pathname whose device is + ;; "emacs-buffer". + (if (eql 0 (search "emacs-buffer:" path2)) + `(:location + (:buffer ,(subseq path2 (load-time-value (length "emacs-buffer:")))) + , + (:align t)) + `(:location + (:file ,path2) + , + (:align t)))))))) + +#+abcl-introspect +(defimplementation list-callers (thing) + (loop for caller in (sys::callers thing) + when (typep caller 'method) + append (let ((name (mop:generic-function-name + (mop:method-generic-function caller)))) + (mapcar (lambda(s) (sly-location-from-source-annotation thing s)) + (remove `(:method ,@(sys::method-spec-list caller)) + (get + (if (consp name) (second name) name) + 'sys::source) + :key 'car :test-not 'equalp))) + when (symbolp caller) + append (mapcar (lambda(s) (sly-location-from-source-annotation caller s)) + (get caller 'sys::source)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Inspecting + +;;; Although by convention toString() is supposed to be a +;;; non-computationally expensive operation this isn't always the +;;; case, so make its computation a user interaction. +(defparameter *to-string-hashtable* (make-hash-table :weakness :key)) + +(defmethod emacs-inspect ((o t)) + (let* ((type (type-of o)) + (class (ignore-errors (find-class type))) + (jclass (and (typep class 'sys::built-in-class) + (jcall "getClass" o)))) + (let ((parts (sys:inspected-parts o))) + `((:label "Type: ") (:value ,(or class type)) (:Newline) + ,@(if jclass + `((:label "Java type: ") (:value ,jclass) (:newline))) + ,@(if parts + (loop :for (label . value) :in parts + :appending (list + (list :label (string-capitalize label)) + ": " + (list :value value (princ-to-string value)) '(:newline))) + (list '(:label "No inspectable parts, dumping output of CL:DESCRIBE:") + '(:newline) + (with-output-to-string (desc) (describe o desc)))))))) + + +(defun %%prepend-list-to-llist (list llist) + "Takes a list (LIST) and a lazy list (LLIST) and transforms the list items into lazy list items, +which are prepended onto the existing lazy list and returned. + +LIST is destructively modified." + (flet ((lcons (car cdr) (%%lcons car (lambda () cdr)))) + (reduce #'lcons list :initial-value llist :from-end t))) + +(defmethod emacs-inspect ((string string)) + (%%prepend-list-to-llist + (list + '(:label "Value: ") `(:value ,string ,(concatenate 'string "\"" string "\"")) '(:newline) + (if (ignore-errors (jclass string)) + `(:line "Names java class" ,(jclass string)) + "") + #+abcl-introspect + (if (and (jss-p) + (stringp (%%lookup-class-name string :return-ambiguous t :muffle-warning t))) + `(:line + "Abbreviates java class" + ,(let ((it (%%lookup-class-name string :return-ambiguous t :muffle-warning t))) + (jclass it))) + "") + (if (ignore-errors (find-package (string-upcase string))) + `(:line "Names package" ,(find-package (string-upcase string))) + "")) + (call-next-method))) + +#+#.(slynk-backend:with-symbol 'java-exception 'java) +(defmethod emacs-inspect ((o java:java-exception)) + (append (call-next-method) + (list '(:newline) '(:label "Stack trace") + '(:newline) + (let ((w (jnew "java.io.StringWriter"))) + (jcall "printStackTrace" (java:java-exception-cause o) (jnew "java.io.PrintWriter" w)) + (jcall "toString" w))))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + "Initialization:" (:newline) + (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) + (:label " Form: ") ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#") (:newline) + (:label " Function: ") + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defmethod emacs-inspect ((f function)) + `(,@(when (function-name f) + `((:label "Name: ") + ,(princ-to-string (sys::any-function-name f)) (:newline))) + ,@(multiple-value-bind (args present) (sys::arglist f) + (when present + `((:label "Argument list: ") + ,(princ-to-string args) + (:newline)))) + #+abcl-introspect + ,@(when (documentation f t) + `("Documentation:" (:newline) + ,(documentation f t) (:newline))) + ,@(when (function-lambda-expression f) + `((:label "Lambda expression:") + (:newline) ,(princ-to-string + (function-lambda-expression f)) (:newline))) + (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline) + #+abcl-introspect + ,@(when (jcall "isInstance" (java::jclass "org.armedbear.lisp.CompiledClosure") f) + `((:label "Closed over: ") + ,@(loop + for el in (sys::compiled-closure-context f) + collect `(:value ,el) + collect " ") + (:newline))) + #+abcl-introspect + ,@(when (sys::get-loaded-from f) + (list `(:label "Defined in: ") + `(:value ,(sys::get-loaded-from f) ,(namestring (sys::get-loaded-from f))) + '(:newline))) + ;; I think this should work in older lisps too -- alanr + ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f)))) + (when (plusp (length fields)) + (list* '(:label "Internal fields: ") '(:newline) + (loop for field across fields + do (jcall "setAccessible" field t) ;;; not a great idea esp. wrt. Java9 + append + (let ((value (jcall "get" field f))) + (list " " + `(:label ,(jcall "getName" field)) + ": " + `(:value ,value ,(princ-to-string value)) + '(:newline))))))))) + +(defmethod emacs-inspect ((o java:java-object)) + (if (jinstance-of-p o (jclass "java.lang.Class")) + (emacs-inspect-java-class o) + (emacs-inspect-java-object o))) + +(defvar *sly-tostring-on-demand* nil + "Set to t if you don't want to automatically show toString() for java objects and instead have inspector action to compute") + +(defun static-field? (field) + ;; (plusp (logand #"reflect.Modifier.STATIC" (jcall "getModifiers" field))) + ;; ugly replace with answer to avoid using jss + (plusp (logand 8 (jcall "getModifiers" field)))) + +(defun inspector-java-object-fields (object) + (loop + for super = (java::jobject-class object) then (jclass-superclass super) + while super + ;;; NOTE: In the next line, if I write #'(lambda.... then I + ;;; get an error compiling "Attempt to throw to the + ;;; nonexistent tag DUPLICATABLE-CODE-P.". WTF + for fields + = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x) (jcall "getName" x))) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length fields)) fromline) + append fromline + append + (loop for this across fields + for value = (jcall "get" (progn (jcall "setAccessible" this t) this) object) + for line = `(" " (:label ,(jcall "getName" this)) ": " (:value ,value) (:newline)) + if (static-field? this) + append line into statics + else append line into members + finally (return (append + (if members `((:label "Member fields: ") (:newline) ,@members)) + (if statics `((:label "Static fields: ") (:newline) ,@statics))))))) + +(defun emacs-inspect-java-object (object) + (let ((to-string (lambda () + (handler-case + (setf (gethash object *to-string-hashtable*) + (jcall "toString" object)) + (t (e) + (setf (gethash object *to-string-hashtable*) + (format nil + "Could not invoke toString(): ~A" + e)))))) + (intended-class (cdr (assoc "intendedClass" (sys::inspected-parts object) + :test 'equal)))) + `((:label "Class: ") + (:value ,(jcall "getClass" object) ,(jcall "getName" (jcall "getClass" object) )) (:newline) + ,@(if (and intended-class (not (equal intended-class (jcall "getName" (jcall "getClass" object))))) + `((:label "Intended Class: ") + (:value ,(jclass intended-class) ,intended-class) (:newline))) + ,@(if (or (gethash object *to-string-hashtable*) (not *sly-tostring-on-demand*)) + (label-value-line "toString()" (funcall to-string)) + `((:action "[compute toString()]" ,to-string) (:newline))) + ,@(inspector-java-object-fields object)))) + +(defmethod emacs-inspect ((slot mop::slot-definition)) + `("Name: " + (:value ,(mop:slot-definition-name slot)) + (:newline) + "Documentation:" (:newline) + ,@(when (slot-definition-documentation slot) + `((:value ,(slot-definition-documentation slot)) (:newline))) + (:label "Initialization:") (:newline) + (:label " Args: ") (:value ,(mop:slot-definition-initargs slot)) (:newline) + (:label " Form: ") + ,(if (mop:slot-definition-initfunction slot) + `(:value ,(mop:slot-definition-initform slot)) + "#") (:newline) + " Function: " + (:value ,(mop:slot-definition-initfunction slot)) + (:newline))) + +(defun inspector-java-fields (class) + (loop + for super + = class then (jclass-superclass super) + while super + for fields + = (jcall "getDeclaredFields" super) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length fields)) fromline) + append fromline + append + (loop for this across fields + for pre = (subseq (jcall "toString" this) + 0 + (1+ (position #\. (jcall "toString" this) :from-end t))) + collect " " + collect (list :value this pre) + collect (list :value this (jcall "getName" this) ) + collect '(:newline)))) + +(defun inspector-java-methods (class) + (loop + for super + = class then (jclass-superclass super) + while super + for methods + = (jcall "getDeclaredMethods" super) + for fromline + = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName" super)) '(:newline)) + when (and (plusp (length methods)) fromline) + append fromline + append + (loop for this across methods + for desc = (jcall "toString" this) + for paren = (position #\( desc) + for dot = (position #\. (subseq desc 0 paren) :from-end t) + for pre = (subseq desc 0 dot) + for name = (subseq desc dot paren) + for after = (subseq desc paren) + collect " " + collect (list :value this pre) + collect (list :value this name) + collect (list :value this after) + collect '(:newline)))) + +(defun emacs-inspect-java-class (class) + (let ((has-superclasses (jclass-superclass class)) + (has-interfaces (plusp (length (jclass-interfaces class)))) + (fields (inspector-java-fields class)) + (path (jcall "replaceFirst" + (jcall "replaceFirst" + (jcall "toString" (jcall "getResource" + class + (concatenate 'string + "/" (substitute #\/ #\. (jcall "getName" class)) + ".class"))) + "jar:file:" "") "!.*" ""))) + `((:label ,(format nil "Java Class: ~a" (jcall "getName" class) )) + (:newline) + ,@(when path (list `(:label ,"Loaded from: ") + `(:value ,path) + " " + `(:action "[open in emacs buffer]" ,(lambda() (%%ed-in-emacs `( ,path)))) '(:newline))) + ,@(if has-superclasses + (list* '(:label "Superclasses: ") (butlast (loop for super = (jclass-superclass class) then (jclass-superclass super) + while super collect (list :value super (jcall "getName" super)) collect ", ")))) + ,@(if has-interfaces + (list* '(:newline) '(:label "Implements Interfaces: ") + (butlast (loop for i across (jclass-interfaces class) collect (list :value i (jcall "getName" i)) collect ", ")))) + (:newline) (:label "Methods:") (:newline) + ,@(inspector-java-methods class) + ,@(if fields + (list* + '(:newline) '(:label "Fields:") '(:newline) + fields))))) + +(defmethod emacs-inspect ((object sys::structure-object)) + `((:label "Type: ") (:value ,(type-of object)) (:newline) + (:label "Class: ") (:value ,(class-of object)) (:newline) + ,@(inspector-structure-slot-names-and-values object))) + +(defun inspector-structure-slot-names-and-values (structure) + (let ((structure-def (get (type-of structure) 'system::structure-definition))) + (if structure-def + `((:label "Slots: ") (:newline) + ,@(loop for slotdef in (sys::dd-slots structure-def) + for name = (sys::dsd-name slotdef) + for reader = (sys::dsd-reader slotdef) + for value = (eval `(,reader ,structure)) + append + `(" " (:label ,(string-downcase (string name))) ": " (:value ,value) (:newline)))) + `("No slots available for inspection.")))) + +(defmethod emacs-inspect ((object sys::structure-class)) + (let* ((name (class-name object)) + (def (get name 'system::structure-definition))) + `((:label "Class: ") (:value ,object) (:newline) + (:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array* nil)) (prin1-to-string def))) (:newline) + ,@(parts-for-structure-def name) + ;; copy-paste from slynk fancy inspector + ,@(when (slynk-mop:specializer-direct-methods object) + `((:label "It is used as a direct specializer in the following methods:") + (:newline) + ,@(loop + for method in (specializer-direct-methods object) + for method-spec = (%%method-for-inspect-value method) + collect " " + collect `(:value ,method ,(string-downcase (string (car method-spec)))) + collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr method-spec))) + append (let ((method method)) + `(" " (:action "[remove]" + ,(lambda () (remove-method (slynk-mop::method-generic-function method) method))))) + collect '(:newline) + if (documentation method t) + collect " Documentation: " and + collect (%%abbrev-doc (documentation method t)) and + collect '(:newline))))))) + +(defun parts-for-structure-def-slot (def) + `((:label ,(string-downcase (sys::dsd-name def))) + " reader: " (:value ,(sys::dsd-reader def) + ,(string-downcase (string (sys::dsd-reader def)))) + ", index: " (:value ,(sys::dsd-index def)) + ,@(if (sys::dsd-initform def) + `(", initform: " (:value ,(sys::dsd-initform def)))) + ,@(if (sys::dsd-read-only def) + '(", Read only")))) + +(defun parts-for-structure-def (name) + (let ((structure-def (get name 'system::structure-definition ))) + (append + (loop for accessor in '(dd-name dd-conc-name dd-default-constructor dd-constructors dd-copier dd-include dd-type + dd-named dd-initial-offset dd-predicate dd-print-function dd-print-object + dd-inherited-accessors) + for key = (intern (subseq (string accessor) 3) 'keyword) + for fsym = (find-symbol (string accessor) 'system) + for value = (eval `(,fsym ,structure-def)) + append `((:label ,(string-capitalize (string key))) ": " (:value ,value) (:newline))) + (let* ((direct (sys::dd-direct-slots structure-def) ) + (all (sys::dd-slots structure-def)) + (inherited (set-difference all direct))) + `((:label "Direct slots: ") (:newline) + ,@(loop for slotdef in direct + append `(" " ,@(parts-for-structure-def-slot slotdef) + (:newline))) + ,@(if inherited + (append '((:label "Inherited slots: ") (:newline)) + (loop for slotdef in inherited + append `(" " (:label ,(string-downcase (string (sys::dsd-name slotdef)))) + (:value ,slotdef "slot definition") + (:newline)))))))))) + +;;;; Multithreading + +(defimplementation spawn (fn &key name) + (threads:make-thread (lambda () (funcall fn)) :name name)) + +(defvar *thread-plists* (make-hash-table) ; should be a weak table + "A hashtable mapping threads to a plist.") + +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'id) + (setf (getf (gethash thread *thread-plists*) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plists*) 'id)))) + +(defimplementation thread-name (thread) + (threads:thread-name thread)) + +(defimplementation thread-status (thread) + (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread))) + +(defimplementation make-lock (&key name) + (declare (ignore name)) + (threads:make-thread-lock)) + +(defimplementation call-with-lock-held (lock function) + (threads:with-thread-lock (lock) (funcall function))) + +(defimplementation current-thread () + (threads:current-thread)) + +(defimplementation all-threads () + (copy-list (threads:mapcar-threads #'identity))) + +(defimplementation thread-alive-p (thread) + (member thread (all-threads))) + +(defimplementation interrupt-thread (thread fn) + (threads:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (threads:destroy-thread thread)) + +(defstruct mailbox + (queue '())) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (threads:synchronized-on *thread-plists* + (or (getf (gethash thread *thread-plists*) 'mailbox) + (setf (getf (gethash thread *thread-plists*) 'mailbox) + (make-mailbox))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (threads:synchronized-on mbox + (setf (mailbox-queue mbox) + (nconc (mailbox-queue mbox) (list message))) + (threads:object-notify-all mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread)))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (threads:synchronized-on mbox + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))) + (when (eq timeout t) (return (values nil t))) + (threads:object-wait mbox 0.3)))))) + +(defimplementation quit-lisp () + (ext:exit)) + +;; FIXME probably should be promoted to other lisps but I don't want to mess with them +(defvar *inspector-print-case* *print-case*) + +(defimplementation call-with-syntax-hooks (fn) + (let ((*print-case* *inspector-print-case*)) + (funcall fn))) + +;;; +#+#.(slynk-backend:with-symbol 'package-local-nicknames 'ext) +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) + +;; all the defimplentations aren't compiled. Compile them. Set their +;; function name to be the same as the implementation name so +;; meta-. works. + +#+abcl-introspect +(eval-when (:load-toplevel :execute) + (loop for s in slynk-backend::*interface-functions* + for impl = (get s 'slynk-backend::implementation) + do (when (and impl (not (compiled-function-p impl))) + (let ((name (gensym))) + (compile name impl) + (let ((compiled (symbol-function name))) + (system::%set-lambda-name compiled (second (sys::lambda-name impl))) + (setf (get s 'slynk-backend::implementation) compiled)))))) + blob - /dev/null blob + 44573c837fb943975ca1366eee833e1a620932e3 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/allegro.lisp @@ -0,0 +1,1116 @@ +;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*- +;;; +;;; slynk-allegro.lisp --- Allegro CL specific code for SLY. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage slynk-allegro + (:use cl slynk-backend)) + +(in-package slynk-allegro) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :sock) + (require :process) + #+(version>= 8 2) + (require 'lldb) + ) + +(defimplementation gray-package-name () + '#:excl) + +;;; slynk-mop + +(import-slynk-mop-symbols :clos '(:slot-definition-documentation)) + +(defun slynk-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; UTF8 + +(define-symbol-macro utf8-ef + (load-time-value + (excl:crlf-base-ef (excl:find-external-format :utf-8)) + t)) + +(defimplementation string-to-utf8 (s) + (excl:string-to-octets s :external-format utf8-ef + :null-terminate nil)) + +(defimplementation utf8-to-string (u) + (excl:octets-to-string u :external-format utf8-ef)) + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (socket:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format buffering + timeout) + (declare (ignore buffering timeout)) + (let ((s (socket:accept-connection socket :wait t))) + (when external-format + (setf (stream-external-format s) external-format)) + s)) + +(defimplementation socket-fd (stream) + (excl::stream-input-handle stream)) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix") + (:emacs-mule "emacs-mule" "emacs-mule-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + (and e (excl:crlf-base-ef + (excl:find-external-format (car e) + :try-variant t))))) + +;;;; Unix signals + +(defimplementation getpid () + (excl::getpid)) + +(defimplementation lisp-implementation-type-name () + "allegro") + +(defimplementation set-default-directory (directory) + (let* ((dir (namestring (truename (merge-pathnames directory))))) + (setf *default-pathname-defaults* (pathname (excl:chdir dir))) + dir)) + +(defimplementation default-directory () + (namestring (excl:current-directory))) + +;;;; Misc + +(defimplementation arglist (symbol) + (handler-case (excl:arglist symbol) + (simple-error () :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + #+(version>= 8 0) + (excl::walk-form form) + #-(version>= 8 0) + (excl::walk form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (ignore-errors + (documentation sym kind)) + :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (check-type f function) + (cross-reference::object-to-function-name f)) + +;;;; Debugger + +(defvar *sly-db-topframe*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let ((*sly-db-topframe* (find-topframe)) + (excl::*break-hook* nil)) + (funcall debugger-loop-fn))) + +(defimplementation sly-db-break-at-start (fname) + ;; :print-before is kind of mis-used but we just want to stuff our + ;; break form somewhere. This does not work for setf, :before and + ;; :after methods, which need special syntax in the trace call, see + ;; ACL's doc/debugging.htm chapter 10. + (eval `(trace (,fname + :print-before + ((break "Function start breakpoint of ~A" ',fname))))) + `(:ok ,(format nil "Set breakpoint at start of ~S" fname))) + +(defun find-topframe () + (let ((magic-symbol (intern (symbol-name :slynk-debugger-hook) + (find-package :slynk))) + (top-frame (excl::int-newest-frame (excl::current-thread)))) + (loop for frame = top-frame then (next-frame frame) + for i from 0 + while (and frame (< i 30)) + when (eq (debugger:frame-name frame) magic-symbol) + return (next-frame frame) + finally (return top-frame)))) + +(defun next-frame (frame) + (let ((next (excl::int-next-older-frame frame))) + (cond ((not next) nil) + ((debugger:frame-visible-p next) next) + (t (next-frame next))))) + +(defun nth-frame (index) + (do ((frame *sly-db-topframe* (next-frame frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (next-frame f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (debugger:output-frame stream frame :moderate)) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for i from 0 below (debugger:frame-number-vars frame) + collect (list :name (debugger:frame-var-name frame i) + :id 0 + :value (debugger:frame-var-value frame i))))) + +(defimplementation frame-arguments (index) + (let ((frame (nth-frame index))) + ;; (values-list (debugger::.actuals frame)) + (values-list + (loop for i from 0 below (debugger:frame-number-vars frame) + unless (eq :local (debugger:frame-var-type frame i)) + collect (debugger:frame-var-value frame i))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (debugger:frame-var-value frame var))) + +(defimplementation disassemble-frame (index) + (let ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun) + (disassemble (debugger:frame-function frame))))) + +(defimplementation frame-source-location (index) + (let* ((frame (nth-frame index))) + (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame) + (declare (ignore x xx xxx)) + (cond ((and pc + #+(version>= 8 2) + (pc-source-location fun pc) + #-(version>= 8 2) + (function-source-location fun))) + (t ; frames for unbound functions etc end up here + (cadr (car (fspec-definition-locations + (car (debugger:frame-expression frame)))))))))) + +(defun function-source-location (fun) + (cadr (car (fspec-definition-locations + (xref::object-to-function-name fun))))) + +#+(version>= 8 2) +(defun pc-source-location (fun pc) + (let* ((debug-info (excl::function-source-debug-info fun))) + (cond ((not debug-info) + (function-source-location fun)) + (t + (let* ((code-loc (find-if (lambda (c) + (<= (- pc (sys::natural-width)) + (let ((x (excl::ldb-code-pc c))) + (or x -1)) + pc)) + debug-info))) + (cond ((not code-loc) + (ldb-code-to-src-loc (aref debug-info 0))) + (t + (ldb-code-to-src-loc code-loc)))))))) + +#+(version>= 8 2) +(defun ldb-code-to-src-loc (code) + (declare (optimize debug)) + (let* ((func (excl::ldb-code-func code)) + (debug-info (excl::function-source-debug-info func)) + (start (and debug-info + (loop for i from (excl::ldb-code-index code) downto 0 + for bpt = (aref debug-info i) + for start = (excl::ldb-code-start-char bpt) + when start + return (if (listp start) + (first start) + start)))) + (src-file (and func (excl:source-file func)))) + (cond (start + (buffer-or-file-location src-file start)) + (func + (let* ((debug-info (excl::function-source-debug-info func)) + (whole (aref debug-info 0)) + (paths (source-paths-of (excl::ldb-code-source whole) + (excl::ldb-code-source code))) + (path (if paths (longest-common-prefix paths) '())) + (start 0)) + (buffer-or-file + src-file + (lambda (file) + (make-location `(:file ,file) + `(:source-path (0 . ,path) ,start))) + (lambda (buffer bstart) + (make-location `(:buffer ,buffer) + `(:source-path (0 . ,path) + ,(+ bstart start))))))) + (t + nil)))) + +(defun longest-common-prefix (sequences) + (assert sequences) + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix sequences))) + +(defun source-paths-of (whole part) + (let ((result '())) + (labels ((walk (form path) + (cond ((eq form part) + (push (reverse path) result)) + ((consp form) + (loop for i from 0 while (consp form) do + (walk (pop form) (cons i path))))))) + (walk whole '()) + (reverse result)))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + ;; let-bind lexical variables + (let ((vars (loop for i below (debugger:frame-number-vars frame) + for name = (debugger:frame-var-name frame i) + if (typep name '(and symbol (not null) (not keyword))) + collect `(,name ',(debugger:frame-var-value frame i))))) + (debugger:eval-form-in-context + `(let* ,vars ,form) + (debugger:environment-of-frame frame))))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (exp (debugger:frame-expression frame))) + (typecase exp + ((cons symbol) (symbol-package (car exp))) + ((cons (cons (eql :internal) (cons symbol))) + (symbol-package (cadar exp)))))) + +(defimplementation return-from-frame (frame-number form) + (let ((frame (nth-frame frame-number))) + (multiple-value-call #'debugger:frame-return + frame (debugger:eval-form-in-context + form + (debugger:environment-of-frame frame))))) + +(defimplementation frame-restartable-p (frame) + (handler-case (debugger:frame-retryable-p frame) + (serious-condition (c) + (declare (ignore c)) + ;; How to log this? Should we? + nil))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (cond ((frame-restartable-p frame) + (apply #'debugger:frame-retry frame (debugger:frame-function frame) + (cdr (debugger:frame-expression frame)))) + (t "Frame is not retryable")))) + +;;;; Compiler hooks + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +(defun compiler-note-p (object) + (member (type-of object) '(excl::compiler-note compiler::compiler-note))) + +(defun redefinition-p (condition) + (and (typep condition 'style-warning) + (every #'char-equal "redefin" (princ-to-string condition)))) + +(defun compiler-undefined-functions-called-warning-p (object) + (typep object 'excl:compiler-undefined-functions-called-warning)) + +(deftype compiler-note () + `(satisfies compiler-note-p)) + +(deftype redefinition () + `(satisfies redefinition-p)) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +(defun handle-compiler-warning (condition) + (declare (optimize (debug 3) (speed 0) (space 0))) + (cond ((and #-(version>= 10 0) (not *buffer-name*) + (compiler-undefined-functions-called-warning-p condition)) + (handle-undefined-functions-warning condition)) + ((and (typep condition 'excl::compiler-note) + (let ((format (slot-value condition 'excl::format-control))) + (and (search "Closure" format) + (search "will be stack allocated" format)))) + ;; Ignore "Closure will be stack allocated" notes. + ;; That occurs often but is usually uninteresting. + ) + (t + (signal-compiler-condition + :original-condition condition + :severity (etypecase condition + (redefinition :redefinition) + (style-warning :style-warning) + (warning :warning) + (compiler-note :note) + (reader-error :read-error) + (error :error)) + :message (format nil "~A" condition) + :location (compiler-warning-location condition))))) + +(defun condition-pathname-and-position (condition) + (let* ((context #+(version>= 10 0) + (getf (slot-value condition 'excl::plist) + :source-context)) + (location-available (and context + (excl::source-context-start-char context)))) + (cond (location-available + (values (excl::source-context-pathname context) + (when-let (start-char (excl::source-context-start-char context)) + (let ((position (if (listp start-char) ; HACK + (first start-char) + start-char))) + (if (typep condition 'excl::compiler-free-reference-warning) + position + (1+ position)))))) + ((typep condition 'reader-error) + (let ((pos (car (last (slot-value condition 'excl::format-arguments)))) + (file (pathname (stream-error-stream condition)))) + (when (integerp pos) + (values file pos)))) + (t + (let ((loc (getf (slot-value condition 'excl::plist) :loc))) + (when loc + (destructuring-bind (file . pos) loc + (let ((start + (if (consp pos) + ;; FIXME: report this bug to Franz. See + ;; the commit message for recipe + #+(version>= 10 1) + (if (typep + condition + 'excl::compiler-inconsistent-name-usage-warning) + (second pos) (first pos)) + #-(version>= 10 1) + (first pos) + pos))) + (values file start))))))))) + +(defun compiler-warning-location (condition) + (multiple-value-bind (pathname position) + (condition-pathname-and-position condition) + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (if position + (list :offset 1 (1- position)) + (list :offset *buffer-start-position* 0)))) + (pathname + (make-location + (list :file (namestring (truename pathname))) + #+(version>= 10 1) + (list :offset 1 position) + #-(version>= 10 1) + (list :position (1+ position)))) + (t + (make-error-location "No error location available."))))) + +;; TODO: report it as a bug to Franz that the condition's plist +;; slot contains (:loc nil). +(defun handle-undefined-functions-warning (condition) + (let ((fargs (slot-value condition 'excl::format-arguments))) + (loop for (fname . locs) in (car fargs) do + (dolist (loc locs) + (multiple-value-bind (pos file) (ecase (length loc) + (2 (values-list loc)) + (3 (destructuring-bind + (start end file) loc + (declare (ignore end)) + (values start file)))) + (signal-compiler-condition + :original-condition condition + :severity :warning + :message (format nil "Undefined function referenced: ~S" + fname) + :location (make-location (list :file file) + #+(version>= 9 0) + (list :offset 1 pos) + #-(version>= 9 0) + (list :position (1+ pos))))))))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-compiler-warning) + (compiler-note #'handle-compiler-warning) + (reader-error #'handle-compiler-warning)) + (funcall function))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file) + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + (compile-file *compile-filename* + :output-file output-file + :load-after-compile load-p + :external-format external-format))) + (reader-error () (values nil nil t)))) + +(defun call-with-temp-file (fn) + (let ((tmpname (system:make-temp-file-name))) + (unwind-protect + (with-open-file (file tmpname :direction :output :if-exists :error) + (funcall fn file tmpname)) + (delete-file tmpname)))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun write-tracking-preamble (stream file file-offset) + "Instrument the top of the temporary file to be compiled. + +The header tells allegro that any definitions compiled in the temp +file should be found in FILE exactly at FILE-OFFSET. To get Allegro +to do this, this factors in the length of the inserted header itself." + (with-standard-io-syntax + (let* ((*package* (find-package :keyword)) + (source-pathname-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*source-pathname* + (pathname ,(sys::frob-source-file file))))) + (source-pathname-string (write-to-string source-pathname-form)) + (position-form-length-bound 160) ; should be enough for everyone + (header-length (+ (length source-pathname-string) + position-form-length-bound)) + (position-form + `(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setq excl::*partial-source-file-p* ,(- file-offset + header-length + 1 ; for the newline + )))) + (position-form-string (write-to-string position-form)) + (padding-string (make-string (- position-form-length-bound + (length position-form-string)) + :initial-element #\;))) + (write-string source-pathname-string stream) + (write-string position-form-string stream) + (write-string padding-string stream) + (write-char #\newline stream)))) + +(defun compile-from-temp-file (string buffer offset file) + (call-with-temp-file + (lambda (stream filename) + (when (and file offset (probe-file file)) + (write-tracking-preamble stream file offset)) + (write-string string stream) + (finish-output stream) + (multiple-value-bind (binary-filename warnings? failure?) + (let ((sys:*source-file-types* '(nil)) ; suppress .lisp extension + #+(version>= 8 2) + (compiler:save-source-level-debug-info-switch t) + (excl:*redefinition-warnings* nil)) + (compile-file filename)) + (declare (ignore warnings?)) + (when binary-filename + (let ((excl:*load-source-file-info* t) + #+(version>= 8 2) + (excl:*load-source-debug-info* t)) + excl::*source-pathname* + (load binary-filename)) + (when (and buffer offset (or (not file) + (not (probe-file file)))) + (setf (gethash (pathname stream) *temp-file-map*) + (list buffer offset))) + (delete-file binary-filename)) + (not failure?))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column policy)) + (handler-case + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (compile-from-temp-file string buffer position filename))) + (reader-error () nil))) + +;;;; Definition Finding + +(defun buffer-or-file (file file-fun buffer-fun) + (let* ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer start) probe + (funcall buffer-fun buffer start))) + (t (funcall file-fun (namestring (truename file))))))) + +(defun buffer-or-file-location (file offset) + (buffer-or-file file + (lambda (filename) + (make-location `(:file ,filename) + `(:position ,(1+ offset)))) + (lambda (buffer start) + (make-location `(:buffer ,buffer) + `(:offset ,start ,offset))))) + +(defun fspec-primary-name (fspec) + (etypecase fspec + (symbol fspec) + (list (fspec-primary-name (second fspec))))) + +(defun find-definition-in-file (fspec type file top-level) + (let* ((part + (or (scm::find-definition-in-definition-group + fspec type (scm:section-file :file file) + :top-level top-level) + (scm::find-definition-in-definition-group + (fspec-primary-name fspec) + type (scm:section-file :file file) + :top-level top-level))) + (start (and part + (scm::source-part-start part))) + (pos (if start + (list :offset 1 start) + (list :function-name (string (fspec-primary-name fspec)))))) + (make-location (list :file (namestring (truename file))) + pos))) + +(defun find-fspec-location (fspec type file top-level) + (handler-case + (etypecase file + (pathname + (let ((probe (gethash file *temp-file-map*))) + (cond (probe + (destructuring-bind (buffer offset) probe + (make-location `(:buffer ,buffer) + `(:offset ,offset 0)))) + (t + (find-definition-in-file fspec type file top-level))))) + ((member :top-level) + (make-error-location "Defined at toplevel: ~A" + (fspec->string fspec)))) + (error (e) + (make-error-location "Error: ~A" e)))) + +(defun fspec->string (fspec) + (typecase fspec + (symbol (let ((*package* (find-package :keyword))) + (prin1-to-string fspec))) + (list (format nil "(~A ~A)" + (prin1-to-string (first fspec)) + (let ((*package* (find-package :keyword))) + (prin1-to-string (second fspec))))) + (t (princ-to-string fspec)))) + +(defun fspec-definition-locations (fspec) + (cond + ((and (listp fspec) (eq (car fspec) :internal)) + (destructuring-bind (_internal next _n) fspec + (declare (ignore _internal _n)) + (fspec-definition-locations next))) + (t + (let ((defs (excl::find-source-file fspec))) + (when (and (null defs) + (listp fspec) + (string= (car fspec) '#:method)) + ;; If methods are defined in a defgeneric form, the source location is + ;; recorded for the gf but not for the methods. Therefore fall back to + ;; the gf as the likely place of definition. + (setq defs (excl::find-source-file (second fspec)))) + (if (null defs) + (list + (list fspec + (make-error-location "Unknown source location for ~A" + (fspec->string fspec)))) + (loop for (fspec type file top-level) in defs collect + (list (list type fspec) + (find-fspec-location fspec type file top-level)))))))) + +(defimplementation find-definitions (symbol) + (fspec-definition-locations symbol)) + +(defimplementation find-source-location (obj) + (first (rest (first (fspec-definition-locations obj))))) + +;;;; XREF + +(defmacro defxref (name relation name1 name2) + `(defimplementation ,name (x) + (xref-result (xref:get-relation ,relation ,name1 ,name2)))) + +(defxref who-calls :calls :wild x) +(defxref calls-who :calls x :wild) +(defxref who-references :uses :wild x) +(defxref who-binds :binds :wild x) +(defxref who-macroexpands :macro-calls :wild x) +(defxref who-sets :sets :wild x) + +(defun xref-result (fspecs) + (loop for fspec in fspecs + append (fspec-definition-locations fspec))) + +;; list-callers implemented by groveling through all fbound symbols. +;; Only symbols are considered. Functions in the constant pool are +;; searched recursively. Closure environments are ignored at the +;; moment (constants in methods are therefore not found). + +(defun map-function-constants (function fn depth) + "Call FN with the elements of FUNCTION's constant pool." + (do ((i 0 (1+ i)) + (max (excl::function-constant-count function))) + ((= i max)) + (let ((c (excl::function-constant function i))) + (cond ((and (functionp c) + (not (eq c function)) + (plusp depth)) + (map-function-constants c fn (1- depth))) + (t + (funcall fn c)))))) + +(defun in-constants-p (fun symbol) + (map-function-constants fun + (lambda (c) + (when (eq c symbol) + (return-from in-constants-p t))) + 3)) + +(defun function-callers (name) + (let ((callers '())) + (do-all-symbols (sym) + (when (fboundp sym) + (let ((fn (fdefinition sym))) + (when (in-constants-p fn name) + (push sym callers))))) + callers)) + +(defimplementation list-callers (name) + (xref-result (function-callers name))) + +(defimplementation list-callees (name) + (let ((result '())) + (map-function-constants (fdefinition name) + (lambda (c) + (when (fboundp c) + (push c result))) + 2) + (xref-result result))) + +;;;; Profiling + +;; Per-function profiling based on description in +;; http://www.franz.com/support/documentation/8.0/\ +;; doc/runtime-analyzer.htm#data-collection-control-2 + +(defvar *profiled-functions* ()) +(defvar *profile-depth* 0) + +(defmacro with-redirected-y-or-n-p (&body body) + ;; If the profiler is restarted when the data from the previous + ;; session is not reported yet, the user is warned via Y-OR-N-P. + ;; As the CL:Y-OR-N-P question is (for some reason) not directly + ;; sent to the Sly user, the function CL:Y-OR-N-P is temporarily + ;; overruled. + `(let* ((pkg (find-package :common-lisp)) + (saved-pdl (excl::package-definition-lock pkg)) + (saved-ynp (symbol-function 'cl:y-or-n-p))) + (setf (excl::package-definition-lock pkg) nil + (symbol-function 'cl:y-or-n-p) + (symbol-function (slynk-backend:find-symbol2 "slynk:y-or-n-p-in-emacs"))) + (unwind-protect + (progn ,@body) + (setf (symbol-function 'cl:y-or-n-p) saved-ynp + (excl::package-definition-lock pkg) saved-pdl)))) + +(defun start-acl-profiler () + (with-redirected-y-or-n-p + (prof:start-profiler :type :time :count t + :start-sampling-p nil :verbose nil))) +(defun acl-profiler-active-p () + (not (eq (prof:profiler-status :verbose nil) :inactive))) + +(defun stop-acl-profiler () + (prof:stop-profiler :verbose nil)) + +(excl:def-fwrapper profile-fwrapper (&rest args) + ;; Ensures sampling is done during the execution of the function, + ;; taking into account recursion. + (declare (ignore args)) + (cond ((zerop *profile-depth*) + (let ((*profile-depth* (1+ *profile-depth*))) + (prof:start-sampling) + (unwind-protect (excl:call-next-fwrapper) + (prof:stop-sampling)))) + (t + (excl:call-next-fwrapper)))) + +(defimplementation profile (fname) + (unless (acl-profiler-active-p) + (start-acl-profiler)) + (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper) + (push fname *profiled-functions*)) + +(defimplementation profiled-functions () + *profiled-functions*) + +(defimplementation unprofile (fname) + (excl:funwrap fname 'profile-fwrapper) + (setq *profiled-functions* (remove fname *profiled-functions*))) + +(defimplementation profile-report () + (prof:show-flat-profile :verbose nil) + (when *profiled-functions* + (start-acl-profiler))) + +(defimplementation profile-reset () + (when (acl-profiler-active-p) + (stop-acl-profiler) + (start-acl-profiler)) + "Reset profiling counters.") + +;;;; Inspecting + +(excl:without-redefinition-warnings +(defmethod emacs-inspect ((o t)) + (allegro-inspect o))) + +(defmethod emacs-inspect ((o function)) + (allegro-inspect o)) + +(defmethod emacs-inspect ((o standard-object)) + (allegro-inspect o)) + +(defun allegro-inspect (o) + (loop for (d dd) on (inspect::inspect-ctl o) + append (frob-allegro-field-def o d) + until (eq d dd))) + +(defun frob-allegro-field-def (object def) + (with-struct (inspect::field-def- name type access) def + (ecase type + ((:unsigned-word :unsigned-byte :unsigned-natural + :unsigned-long :unsigned-half-long + :unsigned-3byte :unsigned-long32) + (label-value-line name (inspect::component-ref-v object access type))) + ((:lisp :value :func) + (label-value-line name (inspect::component-ref object access))) + (:indirect + (destructuring-bind (prefix count ref set) access + (declare (ignore set prefix)) + (loop for i below (funcall count object) + append (label-value-line (format nil "~A-~D" name i) + (funcall ref object i)))))))) + +;;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (mp:start-scheduler) + (funcall continuation)) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + +(defvar *process-plist-lock* (mp:make-process-lock :name "process-plist-lock")) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + #+(version>= 10 0) + (mp:process-sequence thread) + #-(version> 10 0) + (mp:with-process-lock (*process-plist-lock*) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id mp:*all-processes* + :key + #+(version>= 10 0) + #'mp:process-sequence + #-(version>= 10 0) + (lambda (p) (getf (mp:process-property-list p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (princ-to-string (mp:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :times-resumed (mp:process-times-resumed thread))) + +(defimplementation make-lock (&key name) + (mp:make-process-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-process-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (copy-list mp:*all-processes*)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (lock (mp:make-process-lock :name "process mailbox")) + (queue '() :type list) + (gate (mp:make-gate nil))) + +(defvar *global-mailbox-ht-lock* + (mp:make-process-lock :name '*global-mailbox-ht-lock*)) + +(defvar *mailboxes* (make-hash-table :weak-keys t) + "Threads' mailboxes.") + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-process-lock (*global-mailbox-ht-lock*) + (or (gethash thread *mailboxes*) + (setf (gethash thread *mailboxes*) (make-mailbox))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread))) + (mp:with-process-lock ((mailbox.lock mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:open-gate (mailbox.gate mbox))))) + +(defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread))) + (mp:open-gate (mailbox.gate mbox)))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (flet ((open-mailbox () + ;; this opens the mailbox and returns if has the message + ;; we are expecting. But first, check for interrupts. + (check-sly-interrupts) + (mp:with-process-lock ((mailbox.lock mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return-from receive-if (car tail))) + ;; ...if it doesn't, we close the gate (even if it + ;; was already closed) + (mp:close-gate (mailbox.gate mbox)))))) + (cond (timeout + ;; open the mailbox and return asap + (open-mailbox) + (return-from receive-if (values nil t))) + (t + ;; wait until gate open, then open mailbox. If there's + ;; no message there, repeat forever. + (loop + (mp:process-wait + "receive-if (waiting on gate)" + #'mp:gate-open-p (mailbox.gate mbox)) + (open-mailbox))))))) + +(let ((alist '()) + (lock (mp:make-process-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-process-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-process-lock (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (push (cons var form) + #+(version>= 9 0) + excl:*required-thread-bindings* + #-(version>= 9 0) + excl::required-thread-bindings)) + +(defimplementation quit-lisp () + (excl:exit 0 :quiet t)) + + +;;Trace implementations +;;In Allegro 7.0, we have: +;; (trace ) +;; (trace ((method ? (+)))) +;; (trace ((labels ))) +;; (trace ((labels (method (+)) ))) +;; can be a normal name or a (setf name) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + (:defgeneric (toggle-trace-generic-function-methods (second spec))) + ((setf :defmethod :labels :flet) + (toggle-trace-aux (process-fspec-for-allegro spec))) + (:call + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee + :inside (list (process-fspec-for-allegro caller))))))) + +(defun tracedp (fspec) + (member fspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((tracedp fspec) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace (,fspec ,@args))) + (format nil "~S is now traced." fspec)))) + +(defun toggle-trace-generic-function-methods (name) + (let ((methods (mop:generic-function-methods (fdefinition name)))) + (cond ((tracedp name) + (eval `(untrace ,name)) + (dolist (method methods (format nil "~S is now untraced." name)) + (excl:funtrace (mop:method-function method)))) + (t + (eval `(trace (,name))) + (dolist (method methods (format nil "~S is now traced." name)) + (excl:ftrace (mop:method-function method))))))) + +(defun process-fspec-for-allegro (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((setf) fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))) + ((:flet) `(flet ,(process-fspec-for-allegro (second fspec)) + ,(third fspec))))) + (t + fspec))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-keys t args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :values :weak args)) + +(defimplementation hash-table-weakness (hashtable) + (cond ((excl:hash-table-weak-keys hashtable) :key) + ((eq (excl:hash-table-values hashtable) :weak) :value))) + + + +;;;; Character names + +(defimplementation character-completion-set (prefix matchp) + (loop for name being the hash-keys of excl::*name-to-char-table* + when (funcall matchp prefix name) + collect (string-capitalize name))) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:fwrap allegro-spec + indicator + (excl:def-fwrapper allegro-wrapper (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (if replace + (funcall replace args) + (excl:call-next-fwrapper)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally))))))))) + +(defimplementation unwrap (spec indicator) + (let ((allegro-spec (process-fspec-for-allegro spec))) + (excl:funwrap allegro-spec indicator) + allegro-spec)) + +(defimplementation wrapped-p (spec indicator) + (getf (excl:fwrap-order (process-fspec-for-allegro spec)) indicator)) + +;;;; Package-local nicknames +#+(version>= 10 0) +(defimplementation package-local-nicknames (package) + (excl:package-local-nicknames package)) blob - /dev/null blob + c054e9e5555d157674fdf76c7d747ce1fa196046 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/ccl.lisp @@ -0,0 +1,874 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-ccl.lisp --- SLY backend for Clozure CL. +;;; +;;; Copyright (C) 2003, James Bielman +;;; +;;; This program is licensed under the terms of the Lisp Lesser GNU +;;; Public License, known as the LLGPL, and distributed with Clozure CL +;;; as the file "LICENSE". The LLGPL consists of a preamble and the +;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where +;;; these conflict, the preamble takes precedence. +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage slynk-ccl + (:use cl slynk-backend)) + +(in-package slynk-ccl) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (assert (and (= ccl::*openmcl-major-version* 1) + (>= ccl::*openmcl-minor-version* 4)) + () "This file needs CCL version 1.4 or newer")) + +(defimplementation gray-package-name () + "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (ok err) (ignore-errors (require 'xref)) + (unless ok + (warn "~a~%" err)))) + +;;; slynk-mop + +(import-to-slynk-mop + '( ;; classes + cl:standard-generic-function + ccl:standard-slot-definition + cl:method + cl:standard-class + ccl:eql-specializer + openmcl-mop:finalize-inheritance + openmcl-mop:compute-applicable-methods-using-classes + ;; standard-class readers + openmcl-mop:class-default-initargs + openmcl-mop:class-direct-default-initargs + openmcl-mop:class-direct-slots + openmcl-mop:class-direct-subclasses + openmcl-mop:class-direct-superclasses + openmcl-mop:class-finalized-p + cl:class-name + openmcl-mop:class-precedence-list + openmcl-mop:class-prototype + openmcl-mop:class-slots + openmcl-mop:specializer-direct-methods + ;; eql-specializer accessors + openmcl-mop:eql-specializer-object + ;; generic function readers + openmcl-mop:generic-function-argument-precedence-order + openmcl-mop:generic-function-declarations + openmcl-mop:generic-function-lambda-list + openmcl-mop:generic-function-methods + openmcl-mop:generic-function-method-class + openmcl-mop:generic-function-method-combination + openmcl-mop:generic-function-name + ;; method readers + openmcl-mop:method-generic-function + openmcl-mop:method-function + openmcl-mop:method-lambda-list + openmcl-mop:method-specializers + openmcl-mop:method-qualifiers + ;; slot readers + openmcl-mop:slot-definition-allocation + openmcl-mop:slot-definition-documentation + openmcl-mop:slot-value-using-class + openmcl-mop:slot-definition-initargs + openmcl-mop:slot-definition-initform + openmcl-mop:slot-definition-initfunction + openmcl-mop:slot-definition-name + openmcl-mop:slot-definition-type + openmcl-mop:slot-definition-readers + openmcl-mop:slot-definition-writers + openmcl-mop:slot-boundp-using-class + openmcl-mop:slot-makunbound-using-class)) + +(defmacro slynk-sym (sym) + (let ((str (symbol-name sym))) + `(or (find-symbol ,str :slynk) + (error "There is no symbol named ~a in the SLYNK package" ,str)))) +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ccl:encode-string-to-octets string :external-format :utf-8)) + +(defimplementation utf8-to-string (octets) + (ccl:decode-string-from-octets octets :external-format :utf-8)) + +;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (ccl:make-socket :connect :passive :local-port port + :local-host host :reuse-address t + :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (ccl:local-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket &key external-format + buffering timeout) + (declare (ignore buffering timeout)) + (let ((stream-args (and external-format + `(:external-format ,external-format)))) + (ccl:accept-connection socket :wait t :stream-args stream-args))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation socket-fd (stream) + (ccl::ioblock-device (ccl::stream-ioblock stream t))) + +;;; Unix signals + +(defimplementation getpid () + (ccl::getpid)) + +(defimplementation lisp-implementation-type-name () + "ccl") + +;;; Arglist + +(defimplementation arglist (fname) + (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil)) + (ccl:arglist fname)) + (if binding + arglist + :not-available))) + +(defimplementation function-name (function) + (ccl:function-name function)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (let ((flags (ccl:declaration-information decl-identifier))) + (if flags + `(&any ,flags) + (call-next-method)))) + +;;; Compilation + +(defun handle-compiler-warning (condition) + "Resignal a ccl:compiler-warning as slynk-backend:compiler-warning." + (signal 'compiler-condition + :original-condition condition + :message (compiler-warning-short-message condition) + :source-context nil + :severity (compiler-warning-severity condition) + :location (source-note-to-source-location + (ccl:compiler-warning-source-note condition) + (lambda () "Unknown source") + (ccl:compiler-warning-function-name condition)))) + +(defgeneric compiler-warning-severity (condition)) +(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning) +(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning) + +(defgeneric compiler-warning-short-message (condition)) + +;; Pretty much the same as ccl:report-compiler-warning but +;; without the source position and function name stuff. +(defmethod compiler-warning-short-message ((c ccl:compiler-warning)) + (with-output-to-string (stream) + (ccl:report-compiler-warning c stream :short t))) + +;; Needed because `ccl:report-compiler-warning' would return +;; "Nonspecific warning". +(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause)) + (princ-to-string c)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((ccl:compiler-warning 'handle-compiler-warning)) + (let ((ccl:*merge-compiler-warnings* nil)) + (funcall function)))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +;; Use a temp file rather than in-core compilation in order to handle +;; eval-when's as compile-time. +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column policy)) + (with-compilation-hooks () + (let ((temp-file-name (ccl:temp-pathname)) + (ccl:*save-source-locations* t)) + (unwind-protect + (progn + (with-open-file (s temp-file-name :direction :output + :if-exists :error :external-format :utf-8) + (write-string string s)) + (let ((binary-filename (compile-temp-file + temp-file-name filename buffer position))) + (delete-file binary-filename))) + (delete-file temp-file-name))))) + +(defvar *temp-file-map* (make-hash-table :test #'equal) + "A mapping from tempfile names to Emacs buffer names.") + +(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset) + (compile-file temp-file-name + :load t + :compile-file-original-truename + (or buffer-file-name + (progn + (setf (gethash temp-file-name *temp-file-map*) + buffer-name) + temp-file-name)) + :compile-file-original-buffer-offset (1- offset) + :external-format :utf-8)) + +(defimplementation save-image (filename &optional restart-function) + (ccl:save-application filename :toplevel-function restart-function)) + +;;; Cross-referencing + +(defun xref-locations (relation name &optional inverse) + (delete-duplicates + (mapcan #'find-definitions + (if inverse + (ccl::get-relation relation name :wild :exhaustive t) + (ccl::get-relation relation :wild name :exhaustive t))) + :test 'equal)) + +(defimplementation who-binds (name) + (xref-locations :binds name)) + +(defimplementation who-macroexpands (name) + (xref-locations :macro-calls name t)) + +(defimplementation who-references (name) + (remove-duplicates + (append (xref-locations :references name) + (xref-locations :sets name) + (xref-locations :binds name)) + :test 'equal)) + +(defimplementation who-sets (name) + (xref-locations :sets name)) + +(defimplementation who-calls (name) + (remove-duplicates + (append + (xref-locations :direct-calls name) + (xref-locations :indirect-calls name) + (xref-locations :macro-calls name t)) + :test 'equal)) + +(defimplementation who-specializes (class) + (when (symbolp class) + (setq class (find-class class nil))) + (when class + (delete-duplicates + (mapcar (lambda (m) + (car (find-definitions m))) + (ccl:specializer-direct-methods class)) + :test 'equal))) + +(defimplementation list-callees (name) + (remove-duplicates + (append + (xref-locations :direct-calls name t) + (xref-locations :macro-calls name nil)) + :test 'equal)) + +(defimplementation list-callers (symbol) + (delete-duplicates + (mapcan #'find-definitions (ccl:caller-functions symbol)) + :test #'equal)) + +;;; Profiling (alanr: lifted from slynk-clisp) + +(defimplementation profile (fname) + (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + slynk-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (slynk-monitor:unmonitor)) + +(defimplementation profile-report () + (slynk-monitor:report-monitoring)) + +(defimplementation profile-reset () + (slynk-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (slynk-monitor:monitor-all package)) + +;;; Debugging + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(*debugger-hook* nil) + ;; don't let error while printing error take us down + (ccl:*signal-printing-errors* nil)) + (funcall debugger-loop-fn))) + +;; This is called for an async interrupt and is running in a random +;; thread not selected by the user, so don't use thread-local vars +;; such as *emacs-connection*. +(defun find-repl-thread () + (let* ((*break-on-signals* nil) + (conn (funcall (slynk-sym default-connection)))) + (and conn + (ignore-errors ;; this errors if no repl-thread + (funcall (slynk-sym repl-thread) conn))))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ccl:*break-hook* hook) + (ccl:*select-interactive-process-hook* 'find-repl-thread)) + (funcall fun))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ccl:*break-hook* function) + (setq ccl:*select-interactive-process-hook* 'find-repl-thread) + ) + +(defun map-backtrace (function &optional + (start-frame-number 0) + end-frame-number) + "Call FUNCTION passing information about each stack frame + from frames START-FRAME-NUMBER to END-FRAME-NUMBER." + (let ((end-frame-number (or end-frame-number most-positive-fixnum))) + (ccl:map-call-frames function + :origin ccl:*top-error-frame* + :start-frame-number start-frame-number + :count (- end-frame-number start-frame-number)))) + +(defimplementation compute-backtrace (start-frame-number end-frame-number) + (let (result) + (map-backtrace (lambda (p context) + (push (list :frame p context) result)) + start-frame-number end-frame-number) + (nreverse result))) + +(defimplementation print-frame (frame stream) + (assert (eq (first frame) :frame)) + (destructuring-bind (p context) (rest frame) + (let ((lfun (ccl:frame-function p context))) + (format stream "(~S" (or (ccl:function-name lfun) lfun)) + (let* ((unavailable (cons nil nil)) + (args (ccl:frame-supplied-arguments p context + :unknown-marker unavailable))) + (declare (dynamic-extent unavailable)) + (if (eq args unavailable) + (format stream " #") + (dolist (arg args) + (if (eq arg unavailable) + (format stream " #") + (format stream " ~s" arg))))) + (format stream ")")))) + +(defmacro with-frame ((p context) frame-number &body body) + `(call/frame ,frame-number (lambda (,p ,context) . ,body))) + +(defun call/frame (frame-number if-found) + (map-backtrace + (lambda (p context) + (return-from call/frame + (funcall if-found p context))) + frame-number)) + +(defimplementation frame-var-value (frame var) + (with-frame (p context) frame + (cdr (nth var (ccl:frame-named-variables p context))))) + +(defimplementation frame-locals (index) + (with-frame (p context) index + (loop for (name . value) in (ccl:frame-named-variables p context) + collect (list :name name :value value :id 0)))) + +(defimplementation frame-source-location (index) + (with-frame (p context) index + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (if pc + (pc-source-location lfun pc) + (function-source-location lfun))))) + +(defun function-name-package (name) + (etypecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql ccl::traced)) (function-name-package (second name))) + ((cons (eql setf)) (symbol-package (second name))) + ((cons (eql :internal)) (function-name-package (car (last name)))) + ((cons (and symbol (not keyword)) (or (cons list null) + (cons keyword (cons list null)))) + (symbol-package (car name))) + (standard-method (function-name-package (ccl:method-name name))))) + +(defimplementation frame-package (frame-number) + (with-frame (p context) frame-number + (let* ((lfun (ccl:frame-function p context)) + (name (ccl:function-name lfun))) + (function-name-package name)))) + +(defimplementation eval-in-frame (form index) + (with-frame (p context) index + (let ((vars (ccl:frame-named-variables p context))) + (eval `(let ,(loop for (var . val) in vars collect `(,var ',val)) + (declare (ignorable ,@(mapcar #'car vars))) + ,form))))) + +(defimplementation return-from-frame (index form) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (with-frame (p context) index + (declare (ignore context)) + (ccl:apply-in-frame p #'values values)))) + +(defimplementation restart-frame (index) + (with-frame (p context) index + (ccl:apply-in-frame p + (ccl:frame-function p context) + (ccl:frame-supplied-arguments p context)))) + +(defimplementation disassemble-frame (the-frame-number) + (with-frame (p context) the-frame-number + (multiple-value-bind (lfun pc) (ccl:frame-function p context) + (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context) + (disassemble lfun)))) + +;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008) +;; contains some interesting details: +;; +;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects +;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, +;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end +;; positions are file positions (not character positions). The text will +;; be NIL unless text recording was on at read-time. If the original +;; file is still available, you can force missing source text to be read +;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT. +;; +;; Source-note's are associated with definitions (via record-source-file) +;; and also stored in function objects (including anonymous and nested +;; functions). The former can be retrieved via +;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE. +;; +;; The recording behavior is controlled by the new variable +;; CCL:*SAVE-SOURCE-LOCATIONS*: +;; +;; If NIL, don't store source-notes in function objects, and store only +;; the filename for definitions (the latter only if +;; *record-source-file* is true). +;; +;; If T, store source-notes, including a copy of the original source +;; text, for function objects and definitions (the latter only if +;; *record-source-file* is true). +;; +;; If :NO-TEXT, store source-notes, but without saved text, for +;; function objects and defintions (the latter only if +;; *record-source-file* is true). This is the default. +;; +;; PC to source mapping is controlled by the new variable +;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a +;; compressed table mapping pc offsets to corresponding source locations. +;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) +;; which returns a source-note for the source at offset pc in the +;; function. + +(defun function-source-location (function) + (source-note-to-source-location + (or (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "Function has no source note: ~A" function)) + (ccl:function-name function))) + +(defun pc-source-location (function pc) + (source-note-to-source-location + (or (ccl:find-source-note-at-pc function pc) + (ccl:function-source-note function) + (function-name-source-note function)) + (lambda () + (format nil "No source note at PC: ~a[~d]" function pc)) + (ccl:function-name function))) + +(defun function-name-source-note (fun) + (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function))) + (and defs + (destructuring-bind ((type . name) srcloc . srclocs) (car defs) + (declare (ignore type name srclocs)) + srcloc)))) + +(defun source-note-to-source-location (source if-nil-thunk &optional name) + (labels ((filename-to-buffer (filename) + (cond ((gethash filename *temp-file-map*) + (list :buffer (gethash filename *temp-file-map*))) + ((probe-file filename) + (list :file (ccl:native-translated-namestring + (truename filename)))) + (t (error "File ~s doesn't exist" filename))))) + (handler-case + (cond ((ccl:source-note-p source) + (let* ((full-text (ccl:source-note-text source)) + (file-name (ccl:source-note-filename source)) + (start-pos (ccl:source-note-start-pos source))) + (make-location + (when file-name (filename-to-buffer (pathname file-name))) + (when start-pos (list :position (1+ start-pos))) + (when full-text + (list :snippet (subseq full-text 0 + (min 40 (length full-text)))))))) + ((and source name) + ;; This branch is probably never used + (make-location + (filename-to-buffer source) + (list :function-name (princ-to-string + (if (functionp name) + (ccl:function-name name) + name))))) + (t `(:error ,(funcall if-nil-thunk)))) + (error (c) `(:error ,(princ-to-string c)))))) + +(defun alphatizer-definitions (name) + (let ((alpha (gethash name ccl::*nx1-alphatizers*))) + (and alpha (ccl:find-definition-sources alpha)))) + +(defun p2-definitions (name) + (let ((nx1-op (gethash name ccl::*nx1-operators*))) + (and nx1-op + (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) ) + (and (array-in-bounds-p dispatch nx1-op) + (let ((p2 (aref dispatch nx1-op))) + (and p2 + (ccl:find-definition-sources p2)))))))) + +(defimplementation find-definitions (name) + (let ((defs (append (or (ccl:find-definition-sources name) + (and (symbolp name) + (fboundp name) + (ccl:find-definition-sources + (symbol-function name)))) + (alphatizer-definitions name) + (p2-definitions name)))) + (loop for ((type . name) . sources) in defs + collect (list (definition-name type name) + (source-note-to-source-location + (find-if-not #'null sources) + (lambda () "No source-note available") + name))))) + +(defimplementation find-source-location (obj) + (let* ((defs (ccl:find-definition-sources obj)) + (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal) + (car defs))) + (note (find-if-not #'null (cdr best-def)))) + (when note + (source-note-to-source-location + note + (lambda () "No source note available"))))) + +(defun definition-name (type object) + (case (ccl:definition-type-name type) + (method (ccl:name-of object)) + (t (list (ccl:definition-type-name type) (ccl:name-of object))))) + +;;; Packages + +#+#.(slynk-backend:with-symbol 'package-local-nicknames 'ccl) +(defimplementation package-local-nicknames (package) + (ccl:package-local-nicknames package)) + +;;; Utilities + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :setf (let ((setf-function-name (ccl:setf-function-spec-name + `(setf ,symbol)))) + (when (fboundp setf-function-name) + (doc 'function setf-function-name)))) + (maybe-push + :type (when (ccl:type-specifier-p symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:setf + (describe (ccl:setf-function-spec-name `(setf ,symbol)))) + (:class + (describe (find-class symbol))) + (:type + (describe (or (find-class symbol nil) symbol))))) + +;; spec ::= (:defmethod {}* ({}*)) +(defun parse-defmethod-spec (spec) + (values (second spec) + (subseq spec 2 (position-if #'consp spec)) + (find-if #'consp (cddr spec)))) + +(defimplementation toggle-trace (spec) + "We currently ignore just about everything." + (let ((what (ecase (first spec) + ((setf) + spec) + ((:defgeneric) + (second spec)) + ((:defmethod) + (multiple-value-bind (name qualifiers specializers) + (parse-defmethod-spec spec) + (find-method (fdefinition name) + qualifiers + specializers)))))) + (cond ((member what (trace) :test #'equal) + (ccl::%untrace what) + (format nil "~S is now untraced." what)) + (t + (ccl:trace-function what) + (format nil "~S is now traced." what))))) + +;;; Macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (ccl:macroexpand-all form env)) + +;;;; Inspection + +(defun comment-type-p (type) + (or (eq type :comment) + (and (consp type) (eq (car type) :comment)))) + +(defmethod emacs-inspect ((o t)) + (let* ((inspector:*inspector-disassembly* t) + (i (inspector:make-inspector o)) + (count (inspector:compute-line-count i))) + (loop for l from 0 below count append + (multiple-value-bind (value label type) (inspector:line-n i l) + (etypecase type + ((member nil :normal) + `(,(or label "") (:value ,value) (:newline))) + ((member :colon) + (label-value-line label value)) + ((member :static) + (list (princ-to-string label) " " `(:value ,value) '(:newline))) + ((satisfies comment-type-p) + (list (princ-to-string label) '(:newline)))))))) + +(defmethod emacs-inspect :around ((o t)) + (if (or (uvector-inspector-p o) + (not (ccl:uvectorp o))) + (call-next-method) + (let ((value (call-next-method))) + (cond ((listp value) + (append value + `((:newline) + (:value ,(make-instance 'uvector-inspector :object o) + "Underlying UVECTOR")))) + (t value))))) + +(defmethod emacs-inspect ((f function)) + (append + (label-value-line "Name" (function-name f)) + `("Its argument list is: " + ,(princ-to-string (arglist f)) (:newline)) + (label-value-line "Documentation" (documentation f t)) + (when (function-lambda-expression f) + (label-value-line "Lambda Expression" + (function-lambda-expression f))) + (when (ccl:function-source-note f) + (label-value-line "Source note" + (ccl:function-source-note f))) + (when (typep f 'ccl:compiled-lexical-closure) + (append + (label-value-line "Inner function" (ccl::closure-function f)) + '("Closed over values:" (:newline)) + (loop for (name value) in (ccl::closure-closed-over-values f) + append (label-value-line (format nil " ~a" name) + value)))))) + +(defclass uvector-inspector () + ((object :initarg :object))) + +(defgeneric uvector-inspector-p (object) + (:method ((object t)) nil) + (:method ((object uvector-inspector)) t)) + +(defmethod emacs-inspect ((uv uvector-inspector)) + (with-slots (object) uv + (loop for i below (ccl:uvsize object) append + (label-value-line (princ-to-string i) (ccl:uvref object i))))) + +(defimplementation type-specifier-p (symbol) + (or (ccl:type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Multiprocessing + +(defvar *known-processes* + (make-hash-table :size 20 :weak :key :test #'eq) + "A map from threads to mailboxes.") + +(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*")) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (ccl:make-lock "thread mailbox")) + (semaphore (ccl:make-semaphore)) + (queue '() :type list)) + +(defimplementation spawn (fun &key name) + (ccl:process-run-function (or name "Anonymous (Slynk)") + fun)) + +(defimplementation thread-id (thread) + (ccl:process-serial-number thread)) + +(defimplementation find-thread (id) + (find id (ccl:all-processes) :key #'ccl:process-serial-number)) + +(defimplementation thread-name (thread) + (ccl:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A" (ccl:process-whostate thread))) + +(defimplementation thread-attributes (thread) + (list :priority (ccl:process-priority thread))) + +(defimplementation make-lock (&key name) + (ccl:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (ccl:with-lock-grabbed (lock) + (funcall function))) + +(defimplementation current-thread () + ccl:*current-process*) + +(defimplementation all-threads () + (ccl:all-processes)) + +(defimplementation kill-thread (thread) + ;;(ccl:process-kill thread) ; doesn't cut it + (ccl::process-initial-form-exited thread :kill)) + +(defimplementation thread-alive-p (thread) + (not (ccl:process-exhausted-p thread))) + +(defimplementation interrupt-thread (thread function) + (ccl:process-interrupt + thread + (lambda () + (let ((ccl:*top-error-frame* (ccl::%current-exception-frame))) + (funcall function))))) + +(defun mailbox (thread) + (ccl:with-lock-grabbed (*known-processes-lock*) + (or (gethash thread *known-processes*) + (setf (gethash thread *known-processes*) (make-mailbox))))) + +(defimplementation send (thread message) + (assert message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (ccl:with-lock-grabbed (mutex) + (ccl:signal-semaphore (mailbox.semaphore mbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox ccl:*current-process*)) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (ccl:with-lock-grabbed (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (ccl:wait-on-semaphore (mailbox.semaphore mbox))))) + +(let ((alist '()) + (lock (ccl:make-lock "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (ccl:with-lock-grabbed (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (ccl:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (ccl:with-lock-grabbed (lock) + (cdr (assoc name alist))))) + +(defimplementation set-default-initial-binding (var form) + (eval `(ccl::def-standard-initial-binding ,var ,form))) + +(defimplementation quit-lisp () + (ccl:quit)) + +(defimplementation set-default-directory (directory) + (let ((dir (truename (merge-pathnames directory)))) + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (ccl:cwd dir) + (default-directory))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation hash-table-weakness (hashtable) + (ccl:hash-table-weak-p hashtable)) + +(pushnew 'deinit-log-output ccl:*save-exit-functions*) blob - /dev/null blob + 15da18974a76fb09f48c3e096081b934e6e829f9 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/clasp.lisp @@ -0,0 +1,730 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-clasp.lisp --- SLY backend for CLASP. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage slynk-clasp + (:use cl slynk-backend)) + +(in-package slynk-clasp) + +;; #+(or) +;; (eval-when (:compile-toplevel :load-toplevel :execute) +;; (set slynk::*log-output* (open "/tmp/sly.log" :direction :output)) +;; (set slynk:*log-events* t)) + +(defmacro sly-dbg (fmt &rest args) + `(funcall (slynk-backend:find-symbol2 "slynk::log-event") + "sly-dbg ~a ~a~%" mp:*current-process* (apply #'format nil ,fmt ,args))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event") + (require :serve-event) + (pushnew :serve-event *features*)) + (when (find-symbol "TEMPORARY-DIRECTORY" "EXT") + (pushnew :temporary-directory *features*))) + +(declaim (optimize (debug 3))) + +;;; Slynk-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-slynk-mop-symbols :clos nil)) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; TCP Server + +(defimplementation preferred-communication-style () + :spawn +#| #+threads :spawn + #-threads nil +|# + ) + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (handler-bind + ((SB-BSD-SOCKETS:ADDRESS-IN-USE-ERROR (lambda (err) + (declare (ignore err)) + (invoke-restart 'use-value)))) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, CLASP uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SLYNK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;;; Unix Integration + +;;; If CLASP is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as CLASP's +;;; main-thread is also the Sly's REPL thread. + +#+clasp-working +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +#+threads +(defun make-interrupt-handler (real-handler) + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler)))) + +#-threads +(defun make-interrupt-handler (real-handler) + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + + +(defimplementation getpid () + (si:getpid)) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation quit-lisp () + (sys:quit)) + + + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(progn + (defun poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist))))) + + (defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-sly-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready)))))) + +) ; #+serve-event (progn ... + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-sly-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun condition-severity (condition) + (etypecase condition + (cmp:redefined-function-warning :redefinition) + (style-warning :style-warning) + (warning :warning) + (reader-error :read-error) + (error :error))) + +(defun %condition-location (origin) + ;; NOTE: If we're compiling in a buffer, the origin + ;; will already be set up with the offset correctly + ;; due to the :source-debug parameters from + ;; swank-compile-string (below). + (make-file-location + (sys:file-scope-pathname + (sys:file-scope origin)) + (sys:source-pos-info-filepos origin))) + +(defun condition-location (origin) + (typecase origin + (null (make-error-location "No error location available")) + (cons (%condition-location (car origin))) + (t (%condition-location origin)))) + +(defun signal-compiler-condition (condition origin) + (signal 'compiler-condition + :original-condition condition + :severity (condition-severity condition) + :message (princ-to-string condition) + :location (condition-location origin))) + +(defun handle-compiler-condition (condition) + ;; First resignal warnings, so that outer handlers - which may choose to + ;; muffle this - get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (signal-compiler-condition (cmp:deencapsulate-compiler-condition condition) + (cmp:compiler-condition-origin condition))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind + (((or error warning) #'handle-compiler-condition)) + (funcall function))) + +(defun mkstemp (name) + (ext:mkstemp #+temporary-directory + (namestring (make-pathname :name name + :defaults (ext:temporary-directory))) + #-temporary-directory + (concatenate 'string "tmp:" name))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (format t "Compiling file input-file = ~a output-file = ~a~%" input-file output-file) + ;; Ignore the output-file and generate our own + (let ((tmp-output-file (compile-file-pathname (mkstemp "clasp-slynk-compile-file-")))) + (format t "Using tmp-output-file: ~a~%" tmp-output-file) + (multiple-value-bind (fasl warnings-p failure-p) + (with-compilation-hooks () + (compile-file input-file :output-file tmp-output-file + :external-format external-format)) + (values fasl warnings-p + (or failure-p + (when load-p + (not (load fasl)))))))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation slynk-compile-string (string &key buffer position filename line column policy) + (declare (ignore column policy)) ;; We may use column in the future + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (mkstemp "clasp-slynk-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (let ((truename (or filename (note-buffer-tmpfile tmp-file buffer)))) + (compile-file tmp-file + :source-debug-pathname (pathname truename) + ;; emacs numbers are 1-based instead of 0-based, + ;; so we have to subtract + :source-debug-lineno (1- line) + :source-debug-offset (1- position))))) + (when fasl-file (load fasl-file)) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (sys:function-lambda-list name) ;; Uses bc-split + (if foundp arglist :not-available))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos::generic-function-name f)) + (function (ext:compiled-function-name f)))) + +;; FIXME +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +;;; modified from sbcl.lisp +(defimplementation collect-macro-forms (form &optional environment) + (let ((macro-forms '()) + (compiler-macro-forms '()) + (function-quoted-forms '())) + (format t "In collect-macro-forms~%") + (cmp:code-walk + (lambda (form environment) + (when (and (consp form) + (symbolp (car form))) + (cond ((eq (car form) 'function) + (push (cadr form) function-quoted-forms)) + ((member form function-quoted-forms) + nil) + ((macro-function (car form) environment) + (push form macro-forms)) + ((not (eq form (sys:compiler-macroexpand-1 form environment))) + (push form compiler-macro-forms)))) + form) + form environment) + (values macro-forms compiler-macro-forms))) + + + + + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + + +;;; Debugging + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of CLASP's slynk backend, that's +;;; a bad idea. + +;; (defun in-slynk-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :slynk) +;; #.(find-package :slynk-backend) +;; #.(ignore-errors (find-package :slynk-mop)) +;; #.(ignore-errors (find-package :slynk-loader)))) +;; t)) + +;; (defun is-slynk-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults slynk-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-slynk-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-slynk-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (clasp-debug:with-stack (stack) + (let ((*backtrace* (clasp-debug:list-stack stack))) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-from-number (frame-number) + (elt *backtrace* frame-number)) + +(defimplementation print-frame (frame stream) + (clasp-debug:prin1-frame-call frame stream)) + +(defimplementation frame-source-location (frame-number) + (let ((csl (clasp-debug:frame-source-position (frame-from-number frame-number)))) + (if (clasp-debug:code-source-line-pathname csl) + (make-location (list :file (namestring (translate-logical-pathname (clasp-debug:code-source-line-pathname csl)))) + (list :line (clasp-debug:code-source-line-line-number csl)) + '(:align t)) + `(:error ,(format nil "No source for frame: ~a" frame-number))))) + +(defimplementation frame-locals (frame-number) + (loop for (var . value) + in (clasp-debug:frame-locals (frame-from-number frame-number)) + for i from 0 + collect (list :name var :id i :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (let* ((frame (frame-from-number frame-number)) + (locals (clasp-debug:frame-locals frame))) + (cdr (nth var-number locals)))) + +(defimplementation disassemble-frame (frame-number) + (clasp-debug:disassemble-frame (frame-from-number frame-number))) + +(defimplementation eval-in-frame (form frame-number) + (let* ((frame (frame-from-number frame-number))) + (eval + `(let (,@(loop for (var . value) + in (clasp-debug:frame-locals frame) + collect `(,var ',value))) + (progn ,form))))) + +#+clasp-working +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +#+clasp-working +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + + +;;;; Definitions + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from CLASP point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun translate-location (location) + (make-location (list :file (namestring (translate-logical-pathname (ext:source-location-pathname location)))) + (list :position (ext:source-location-offset location)) + '(:align t))) + +(defun make-dspec (name location) + (list* (ext:source-location-definer location) + name + (ext:source-location-description location))) + +(defimplementation find-definitions (name) + (loop for kind in ext:*source-location-kinds* + for locations = (ext:source-location name kind) + when locations + nconc (loop for location in locations + collect (list (make-dspec name location) + (translate-location location))))) + +(defun source-location (object) + (let ((location (ext:source-location object t))) + (when location + (translate-location (car location))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + + +;;;; Profiling + +;;;; as clisp and ccl + +(defimplementation profile (fname) + (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + slynk-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (slynk-monitor:unmonitor)) + +(defimplementation profile-report () + (slynk-monitor:report-monitoring)) + +(defimplementation profile-reset () + (slynk-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (slynk-monitor:monitor-all package)) + + +;;;; Threads + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-recursive-mutex name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock :name "SLYLCK")) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (format t "About to with-lock in wake-thread~%") + (mp:with-lock (mutex) + (format t "In wake-thread~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + ;; (sly-dbg "clasp.lisp: send message ~a mutex: ~a~%" message mutex) + ;; (sly-dbg "clasp.lisp: (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + ;; (sly-dbg "clasp.lisp: (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (mp:with-lock (mutex) + ;; (sly-dbg "clasp.lisp: in with-lock (lock-owner mutex) -> ~a~%" (mp:lock-owner mutex)) + ;; (sly-dbg "clasp.lisp: in with-lock (lock-count mutex) -> ~a~%" (mp:lock-count mutex)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sly-dbg "clasp.lisp: send about to broadcast~%") + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + + (defimplementation receive-if (test &optional timeout) + (sly-dbg "Entered receive-if") + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (sly-dbg "receive-if assert") + (assert (or (not timeout) (eq timeout t))) + (loop + (sly-dbg "receive-if check-sly-interrupts") + (check-sly-interrupts) + (sly-dbg "receive-if with-lock") + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (sly-dbg "receive-if when (eq") + (when (eq timeout t) (return (values nil t))) + (sly-dbg "receive-if condition-variable-timedwait") + (mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait 0.2 + (sly-dbg "came out of condition-variable-timedwait") + (sys:check-pending-interrupts))))) + + ) ; #+threads (progn ... + + +(defmethod emacs-inspect ((object sys:cxx-object)) + (let ((encoded (sys:encode object))) + (loop for (key . value) in encoded + append (list (string key) ": " (list :value value) (list :newline))))) + +(defmethod emacs-inspect ((object sys:vaslist)) + (emacs-inspect (sys:list-from-vaslist object))) blob - /dev/null blob + 093762545c3ad6ea623301aa9b2d058329981b3b (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/clisp.lisp @@ -0,0 +1,921 @@ +;;;; -*- indent-tabs-mode: nil -*- + +;;;; SLYNK support for CLISP. + +;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach + +;;;; This program 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 of +;;;; the License, or (at your option) any later version. + +;;;; This program 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 this program; if not, write to the Free +;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +;;;; MA 02111-1307, USA. + +;;; This is work in progress, but it's already usable. Many things +;;; are adapted from other slynk-*.lisp, in particular from +;;; slynk-allegro (I don't use allegro at all, but it's the shortest +;;; one and I found Helmut Eller's code there enlightening). + +;;; This code will work better with recent versions of CLISP (say, the +;;; last release or CVS HEAD) while it may not work at all with older +;;; versions. It is reasonable to expect it to work on platforms with +;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like +;;; systems, but also on Win32. This backend uses the portable xref +;;; from the CMU AI repository and metering.lisp from CLOCC [1], which +;;; are conveniently included in SLY. + +;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/ + +(defpackage slynk-clisp + (:use cl slynk-backend)) + +(in-package slynk-clisp) + +(eval-when (:compile-toplevel) + (unless (string< "2.44" (lisp-implementation-version)) + (error "Need at least CLISP version 2.44"))) + +(defimplementation gray-package-name () + "GRAY") + +;;;; if this lisp has the complete CLOS then we use it, otherwise we +;;;; build up a "fake" slynk-mop and then override the methods in the +;;;; inspector. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *have-mop* + (and (find-package :clos) + (eql :external + (nth-value 1 (find-symbol (string ':standard-slot-definition) + :clos)))) + "True in those CLISP images which have a complete MOP implementation.")) + +#+#.(cl:if slynk-clisp::*have-mop* '(cl:and) '(cl:or)) +(progn + (import-slynk-mop-symbols :clos '(:slot-definition-documentation)) + + (defun slynk-mop:slot-definition-documentation (slot) + (clos::slot-definition-documentation slot))) + +#-#.(cl:if slynk-clisp::*have-mop* '(and) '(or)) +(defclass slynk-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that slynk.lisp will compile and load.")) + +(let ((getpid (or (find-symbol "PROCESS-ID" :system) + ;; old name prior to 2005-03-01, clisp <= 2.33.2 + (find-symbol "PROGRAM-ID" :system) + #+win32 ; integrated into the above since 2005-02-24 + (and (find-package :win32) ; optional modules/win32 + (find-symbol "GetCurrentProcessId" :win32))))) + (defimplementation getpid () ; a required interface + (cond + (getpid (funcall getpid)) + #+win32 ((ext:getenv "PID")) ; where does that come from? + (t -1)))) + +(defimplementation call-with-user-break-handler (handler function) + (handler-bind ((system::simple-interrupt-condition + (lambda (c) + (declare (ignore c)) + (funcall handler) + (when (find-restart 'socket-status) + (invoke-restart (find-restart 'socket-status))) + (continue)))) + (funcall function))) + +(defimplementation lisp-implementation-type-name () + "clisp") + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) directory) + (namestring (setf *default-pathname-defaults* (ext:default-directory)))) + +(defimplementation filename-to-pathname (string) + (cond ((member :cygwin *features*) + (parse-cygwin-filename string)) + (t (parse-namestring string)))) + +(defun parse-cygwin-filename (string) + (multiple-value-bind (match _ drive absolute) + (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t) + (declare (ignore _)) + (assert (and match (if drive absolute t)) () + "Invalid filename syntax: ~a" string) + (let* ((sans-prefix (subseq string (regexp:match-end match))) + (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix))) + (path (loop for name in path collect + (cond ((equal name "..") ':back) + (t name)))) + (directoryp (or (equal string "") + (find (aref string (1- (length string))) "\\/")))) + (multiple-value-bind (file type) + (cond ((and (not directoryp) (last path)) + (let* ((file (car (last path))) + (pos (position #\. file :from-end t))) + (cond ((and pos (> pos 0)) + (values (subseq file 0 pos) + (subseq file (1+ pos)))) + (t file))))) + (make-pathname :host nil + :device nil + :directory (cons + (if absolute :absolute :relative) + (let ((path (if directoryp + path + (butlast path)))) + (if drive + (cons + (regexp:match-string string drive) + path) + path))) + :name file + :type type))))) + +;;;; UTF + +(defimplementation string-to-utf8 (string) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-to-bytes string enc))) + +(defimplementation utf8-to-string (octets) + (let ((enc (load-time-value + (ext:make-encoding :charset "utf-8" :line-terminator :unix) + t))) + (ext:convert-string-from-bytes octets enc))) + +;;;; TCP Server + +(defimplementation create-socket (host port &key backlog) + (socket:socket-server port :interface host :backlog (or backlog 5))) + +(defimplementation local-port (socket) + (socket:socket-server-port socket)) + +(defimplementation close-socket (socket) + (socket:socket-server-close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout)) + (socket:socket-accept socket + :buffered buffering ;; XXX may not work if t + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format (or external-format :default))) + +#-win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams))) + (loop + (cond ((check-sly-interrupts) (return :interrupt)) + (timeout + (socket:socket-status streams 0 0) + (return (loop for (s nil . x) in streams + if x collect s))) + (t + (with-simple-restart (socket-status "Return from socket-status.") + (socket:socket-status streams 0 500000)) + (let ((ready (loop for (s nil . x) in streams + if x collect s))) + (when ready (return ready)))))))) + +#+win32 +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-sly-interrupts) (return :interrupt)) + (t + (let ((ready (remove-if-not #'input-available-p streams))) + (when ready (return ready))) + (when timeout (return nil)) + (sleep 0.1))))) + +#+win32 +;; Some facts to remember (for the next time we need to debug this): +;; - interactive-sream-p returns t for socket-streams +;; - listen returns nil for socket-streams +;; - (type-of ) is 'stream +;; - (type-of *terminal-io*) is 'two-way-stream +;; - stream-element-type on our sockets is usually (UNSIGNED-BYTE 8) +;; - calling socket:socket-status on non sockets signals an error, +;; but seems to mess up something internally. +;; - calling read-char-no-hang on sockets does not signal an error, +;; but seems to mess up something internally. +(defun input-available-p (stream) + (case (stream-element-type stream) + (character + (let ((c (read-char-no-hang stream nil nil))) + (cond ((not c) + nil) + (t + (unread-char c stream) + t)))) + (t + (eq (socket:socket-status (cons stream :input) 0 0) + :input)))) + +;;;; Coding systems + +(defvar *external-format-to-coding-system* + '(((:charset "iso-8859-1" :line-terminator :unix) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ((:charset "iso-8859-1") + "latin-1" "iso-latin-1" "iso-8859-1") + ((:charset "utf-8") "utf-8") + ((:charset "utf-8" :line-terminator :unix) "utf-8-unix") + ((:charset "euc-jp") "euc-jp") + ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix") + ((:charset "us-ascii") "us-ascii") + ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (let ((args (car (rassoc-if (lambda (x) + (member coding-system x :test #'equal)) + *external-format-to-coding-system*)))) + (and args (apply #'ext:make-encoding args)))) + + +;;;; Slynk functions + +(defimplementation arglist (fname) + (block nil + (or (ignore-errors + (let ((exp (function-lambda-expression fname))) + (and exp (return (second exp))))) + (ignore-errors + (return (ext:arglist fname))) + :not-available))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ext:expand-form form)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result ())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push :variable (when (boundp symbol) (doc 'variable))) + (when (fboundp symbol) + (maybe-push + ;; Report WHEN etc. as macros, even though they may be + ;; implemented as special operators. + (if (macro-function symbol) :macro + (typecase (fdefinition symbol) + (generic-function :generic-function) + (function :function) + ;; (type-of 'progn) -> ext:special-operator + (t :special-operator))) + (doc 'function))) + (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt) + (get symbol 'system::setf-expander)); defsetf + (maybe-push :setf (doc 'setf))) + (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp + (get symbol 'system::defstruct-description) + (get symbol 'system::deftype-expander)) + (maybe-push :type (doc 'type))) ; even for 'structure + (when (find-class symbol nil) + (maybe-push :class (doc 'type))) + ;; Let this code work compiled in images without FFI + (let ((types (load-time-value + (and (find-package "FFI") + (symbol-value + (find-symbol "*C-TYPE-TABLE*" "FFI")))))) + ;; Use ffi::*c-type-table* so as not to suffer the overhead of + ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols + ;; which are not FFI type names. + (when (and types (nth-value 1 (gethash symbol types))) + ;; Maybe use (case (head (ffi:deparse-c-type))) + ;; to distinguish struct and union types? + (maybe-push :alien-type :not-documented))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable (describe symbol)) + (:macro (describe (macro-function symbol))) + (:function (describe (symbol-function symbol))) + (:class (describe (find-class symbol))))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defun fspec-pathname (spec) + (let ((path spec) + type + lines) + (when (consp path) + (psetq type (car path) + path (cadr path) + lines (cddr path))) + (when (and path + (member (pathname-type path) + custom:*compiled-file-types* :test #'equal)) + (setq path + (loop for suffix in custom:*source-file-types* + thereis (probe-file (make-pathname :defaults path + :type suffix))))) + (values path type lines))) + +(defun fspec-location (name fspec) + (multiple-value-bind (file type lines) + (fspec-pathname fspec) + (list (if type (list name type) name) + (cond (file + (multiple-value-bind (truename c) + (ignore-errors (truename file)) + (cond (truename + (make-location + (list :file (namestring truename)) + (if (consp lines) + (list* :line lines) + (list :function-name (string name))) + (when (consp type) + (list :snippet (format nil "~A" type))))) + (t (list :error (princ-to-string c)))))) + (t (list :error + (format nil "No source information available for: ~S" + fspec))))))) + +(defimplementation find-definitions (name) + (mapcar #'(lambda (e) (fspec-location name e)) + (documentation name 'sys::file))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defvar *sly-db-backtrace*) + +(defun sly-db-backtrace () + "Return a list ((ADDRESS . DESCRIPTION) ...) of frames." + (let* ((modes '((:all-stack-elements 1) + (:all-frames 2) + (:only-lexical-frames 3) + (:only-eval-and-apply-frames 4) + (:only-apply-frames 5))) + (mode (cadr (assoc :all-stack-elements modes)))) + (do ((frames '()) + (last nil frame) + (frame (sys::the-frame) + (sys::frame-up 1 frame mode))) + ((eq frame last) (nreverse frames)) + (unless (boring-frame-p frame) + (push frame frames))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* (;;(sys::*break-count* (1+ sys::*break-count*)) + ;;(sys::*driver* debugger-loop-fn) + ;;(sys::*fasoutput-stream* nil) + (*sly-db-backtrace* + (let* ((f (sys::the-frame)) + (bt (sly-db-backtrace)) + (rest (member f bt))) + (if rest (nthcdr 8 rest) bt)))) + (funcall debugger-loop-fn))) + +(defun nth-frame (index) + (nth index *sly-db-backtrace*)) + +(defun boring-frame-p (frame) + (member (frame-type frame) '(stack-value bind-var bind-env + compiled-tagbody compiled-block))) + +(defun frame-to-string (frame) + (with-output-to-string (s) + (sys::describe-frame s frame))) + +(defun frame-type (frame) + ;; FIXME: should bind *print-length* etc. to small values. + (frame-string-type (frame-to-string frame))) + +;; FIXME: they changed the layout in 2.44 and not all patterns have +;; been updated. +(defvar *frame-prefixes* + '(("\\[[0-9]\\+\\] frame binding variables" bind-var) + ("<1> # # # " fun) + ("<2> " 2nd-frame) + )) + +(defun frame-string-type (string) + (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string)) + *frame-prefixes*))) + +(defimplementation compute-backtrace (start end) + (let* ((bt *sly-db-backtrace*) + (len (length bt))) + (loop for f in (subseq bt start (min (or end len) len)) + collect f))) + +(defimplementation print-frame (frame stream) + (let* ((str (frame-to-string frame))) + (write-string (extract-frame-line str) + stream))) + +(defun extract-frame-line (frame-string) + (let ((s frame-string)) + (trim-whitespace + (case (frame-string-type s) + ((eval special-op) + (string-match "EVAL frame .*for form \\(.*\\)" s 1)) + (apply + (string-match "APPLY frame for call \\(.*\\)" s 1)) + ((compiled-fun sys-fun fun) + (extract-function-name s)) + (t s))))) + +(defun extract-function-name (string) + (let ((1st (car (split-frame-string string)))) + (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>") + 1st + 1) + (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1) + 1st))) + +(defun split-frame-string (string) + (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)" + (mapcar #'car *frame-prefixes*)))) + (loop for pos = 0 then (1+ (regexp:match-start match)) + for match = (regexp:match rx string :start pos) + if match collect (subseq string pos (regexp:match-start match)) + else collect (subseq string pos) + while match))) + +(defun string-match (pattern string n) + (let* ((match (nth-value n (regexp:match pattern string)))) + (if match (regexp:match-string string match)))) + +(defimplementation eval-in-frame (form frame-number) + (sys::eval-at (nth-frame frame-number) form)) + +(defimplementation frame-locals (frame-number) + (let ((frame (nth-frame frame-number))) + (loop for i below (%frame-count-vars frame) + collect (list :name (%frame-var-name frame i) + :value (%frame-var-value frame i) + :id 0)))) + +(defimplementation frame-var-value (frame var) + (%frame-var-value (nth-frame frame) var)) + +;;; Interpreter-Variablen-Environment has the shape +;;; NIL or #(v1 val1 ... vn valn NEXT-ENV). + +(defun %frame-count-vars (frame) + (cond ((sys::eval-frame-p frame) + (do ((venv (frame-venv frame) (next-venv venv)) + (count 0 (+ count (/ (1- (length venv)) 2)))) + ((not venv) count))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (length (%parse-stack-values frame))) + (t 0))) + +(defun %frame-var-name (frame i) + (cond ((sys::eval-frame-p frame) + (nth-value 0 (venv-ref (frame-venv frame) i))) + (t (format nil "~D" i)))) + +(defun %frame-var-value (frame i) + (cond ((sys::eval-frame-p frame) + (let ((name (venv-ref (frame-venv frame) i))) + (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name)) + (if c + (format-sly-db-condition c) + v)))) + ((member (frame-type frame) '(compiled-fun sys-fun fun special-op)) + (let ((str (nth i (%parse-stack-values frame)))) + (trim-whitespace (subseq str 2)))) + (t (break "Not implemented")))) + +(defun frame-venv (frame) + (let ((env (sys::eval-at frame '(sys::the-environment)))) + (svref env 0))) + +(defun next-venv (venv) (svref venv (1- (length venv)))) + +(defun venv-ref (env i) + "Reference the Ith binding in ENV. +Return two values: NAME and VALUE" + (let ((idx (* i 2))) + (if (< idx (1- (length env))) + (values (svref env idx) (svref env (1+ idx))) + (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) + +(defun %parse-stack-values (frame) + (labels ((next (fp) (sys::frame-down 1 fp 1)) + (parse (fp accu) + (let ((str (frame-to-string fp))) + (cond ((is-prefix-p "- " str) + (parse (next fp) (cons str accu))) + ((is-prefix-p "<1> " str) + ;;(when (eq (frame-type frame) 'compiled-fun) + ;; (pop accu)) + (dolist (str (cdr (split-frame-string str))) + (when (is-prefix-p "- " str) + (push str accu))) + (nreverse accu)) + (t (parse (next fp) accu)))))) + (parse (next frame) '()))) + +(defun is-prefix-p (regexp string) + (if (regexp:match (concatenate 'string "^" regexp) string) t)) + +(defimplementation return-from-frame (index form) + (sys::return-from-eval-frame (nth-frame index) form)) + +(defimplementation restart-frame (index) + (sys::redo-eval-frame (nth-frame index))) + +(defimplementation frame-source-location (index) + `(:error + ,(format nil "frame-source-location not implemented. (frame: ~A)" + (nth-frame index)))) + +;;;; Profiling + +(defimplementation profile (fname) + (eval `(slynk-monitor:monitor ,fname))) ;monitor is a macro + +(defimplementation profiled-functions () + slynk-monitor:*monitored-functions*) + +(defimplementation unprofile (fname) + (eval `(slynk-monitor:unmonitor ,fname))) ;unmonitor is a macro + +(defimplementation unprofile-all () + (slynk-monitor:unmonitor)) + +(defimplementation profile-report () + (slynk-monitor:report-monitoring)) + +(defimplementation profile-reset () + (slynk-monitor:reset-all-monitoring)) + +(defimplementation profile-package (package callers-p methods) + (declare (ignore callers-p methods)) + (slynk-monitor:monitor-all package)) + +;;;; Handle compiler conditions (find out location of error etc.) + +(defmacro compile-file-frobbing-notes ((&rest args) &body body) + "Pass ARGS to COMPILE-FILE, send the compiler notes to +*STANDARD-INPUT* and frob them in BODY." + `(let ((*error-output* (make-string-output-stream)) + (*compile-verbose* t)) + (multiple-value-prog1 + (compile-file ,@args) + (handler-case + (with-input-from-string + (*standard-input* (get-output-stream-string *error-output*)) + ,@body) + (sys::simple-end-of-file () nil))))) + +(defvar *orig-c-warn* (symbol-function 'system::c-warn)) +(defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn)) +(defvar *orig-c-error* (symbol-function 'system::c-error)) +(defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems)) + +(defmacro dynamic-flet (names-functions &body body) + "(dynamic-flet ((NAME FUNCTION) ...) BODY ...) +Execute BODY with NAME's function slot set to FUNCTION." + `(ext:letf* ,(loop for (name function) in names-functions + collect `((symbol-function ',name) ,function)) + ,@body)) + +(defvar *buffer-name* nil) +(defvar *buffer-offset*) + +(defun compiler-note-location () + "Return the current compiler location." + (let ((lineno1 sys::*compile-file-lineno1*) + (lineno2 sys::*compile-file-lineno2*) + (file sys::*compile-file-truename*)) + (cond ((and file lineno1 lineno2) + (make-location (list ':file (namestring file)) + (list ':line lineno1))) + (*buffer-name* + (make-location (list ':buffer *buffer-name*) + (list ':offset *buffer-offset* 0))) + (t + (list :error "No error location available"))))) + +(defun signal-compiler-warning (cstring args severity orig-fn) + (signal 'compiler-condition + :severity severity + :message (apply #'format nil cstring args) + :location (compiler-note-location)) + (apply orig-fn cstring args)) + +(defun c-warn (cstring &rest args) + (signal-compiler-warning cstring args :warning *orig-c-warn*)) + +(defun c-style-warn (cstring &rest args) + (dynamic-flet ((sys::c-warn *orig-c-warn*)) + (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*))) + +(defun c-error (&rest args) + (signal 'compiler-condition + :severity :error + :message (apply #'format nil + (if (= (length args) 3) + (cdr args) + args)) + :location (compiler-note-location)) + (apply *orig-c-error* args)) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((warning #'handle-notification-condition)) + (dynamic-flet ((system::c-warn #'c-warn) + (system::c-style-warn #'c-style-warn) + (system::c-error #'c-error)) + (funcall function)))) + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (signal 'compiler-condition + :original-condition condition + :severity :warning + :message (princ-to-string condition) + :location (compiler-note-location))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (with-compilation-unit () + (multiple-value-bind (fasl-file warningsp failurep) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values fasl-file warningsp + (or failurep + (and load-p + (not (load fasl-file))))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-offset* position)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Portable XREF from the CMU AI repository. + +(setq pxref::*handle-package-forms* '(cl:in-package)) + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls pxref:list-callers) +(defxref who-references pxref:list-readers) +(defxref who-binds pxref:list-setters) +(defxref who-sets pxref:list-setters) +(defxref list-callers pxref:list-callers) +(defxref list-callees pxref:list-callees) + +(defun xref-results (symbols) + (let ((xrefs '())) + (dolist (symbol symbols) + (push (fspec-location symbol symbol) xrefs)) + xrefs)) + +(when (find-package :slynk-loader) + (setf (symbol-function (intern "USER-INIT-FILE" :slynk-loader)) + (lambda () + (let ((home (user-homedir-pathname))) + (and (ext:probe-directory home) + (probe-file (format nil "~A/.slynk.lisp" + (namestring (truename home))))))))) + +;;; Don't set *debugger-hook* to nil on break. +(ext:without-package-lock () + (defun break (&optional (format-string "Break") &rest args) + (if (not sys::*use-clcs*) + (progn + (terpri *error-output*) + (apply #'format *error-output* + (concatenate 'string "*** - " format-string) + args) + (funcall ext:*break-driver* t)) + (let ((condition + (make-condition 'simple-condition + :format-control format-string + :format-arguments args)) + ;;(*debugger-hook* nil) + ;; Issue 91 + ) + (ext:with-restarts + ((continue + :report (lambda (stream) + (format stream (sys::text "Return from ~S loop") + 'break)) + ())) + (with-condition-restarts condition (list (find-restart 'continue)) + (invoke-debugger condition))))) + nil)) + +;;;; Inspecting + +(defmethod emacs-inspect ((o t)) + (let* ((*print-array* nil) (*print-pretty* t) + (*print-circle* t) (*print-escape* t) + (*print-lines* custom:*inspect-print-lines*) + (*print-level* custom:*inspect-print-level*) + (*print-length* custom:*inspect-print-length*) + (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t)) + (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-"))) + (*package* tmp-pack) + (sys::*inspect-unbound-value* (intern "#" tmp-pack))) + (let ((inspection (sys::inspect-backend o))) + (append (list + (format nil "~S~% ~A~{~%~A~}~%" o + (sys::insp-title inspection) + (sys::insp-blurb inspection))) + (loop with count = (sys::insp-num-slots inspection) + for i below count + append (multiple-value-bind (value name) + (funcall (sys::insp-nth-slot inspection) + i) + `((:value ,name) " = " (:value ,value) + (:newline)))))))) + +(defimplementation quit-lisp () + #+lisp=cl (ext:quit) + #-lisp=cl (lisp:quit)) + + +(defimplementation preferred-communication-style () + nil) + +;;; FIXME +;;; +;;; Clisp 2.48 added experimental support for threads. Basically, you +;;; can use :SPAWN now, BUT: +;;; +;;; - there are problems with GC, and threads stuffed into weak +;;; hash-tables as is the case for *THREAD-PLIST-TABLE*. +;;; +;;; See test case at +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429 +;;; +;;; Even though said to be fixed, it's not: +;;; +;;; http://thread.gmane.org/gmane.lisp.clisp.devel/20429/focus=20443 +;;; +;;; - The DYNAMIC-FLET above is an implementation technique that's +;;; probably not sustainable in light of threads. This got to be +;;; rewritten. +;;; +;;; TCR (2009-07-30) + +#+#.(cl:if (cl:find-package "MP") '(:and) '(:or)) +(progn + (defimplementation spawn (fn &key name) + (mp:make-thread fn :name name)) + + (defvar *thread-plist-table-lock* + (mp:make-mutex :name "THREAD-PLIST-TABLE-LOCK")) + + (defvar *thread-plist-table* (make-hash-table :weak :key) + "A hashtable mapping threads to a plist.") + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (mp:with-mutex-lock (*thread-plist-table-lock*) + (or (getf (gethash thread *thread-plist-table*) 'thread-id) + (setf (getf (gethash thread *thread-plist-table*) 'thread-id) + (incf *thread-id-counter*))))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (thread) + (getf (gethash thread *thread-plist-table*) 'thread-id)))) + + (defimplementation thread-name (thread) + ;; To guard against returning #. + (princ-to-string (mp:thread-name thread))) + + (defimplementation thread-status (thread) + (if (thread-alive-p thread) + "RUNNING" + "STOPPED")) + + (defimplementation make-lock (&key name) + (mp:make-mutex :name name :recursive-p t)) + + (defimplementation call-with-lock-held (lock function) + (mp:with-mutex-lock (lock) + (funcall function))) + + (defimplementation current-thread () + (mp:current-thread)) + + (defimplementation all-threads () + (mp:list-threads)) + + (defimplementation interrupt-thread (thread fn) + (mp:thread-interrupt thread :function fn)) + + (defimplementation kill-thread (thread) + (mp:thread-interrupt thread :function t)) + + (defimplementation thread-alive-p (thread) + (mp:thread-active-p thread)) + + (defvar *mailboxes-lock* (make-lock :name "MAILBOXES-LOCK")) + (defvar *mailboxes* (list)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-lock :name "MAILBOX.LOCK")) + (waitqueue (mp:make-exemption :name "MAILBOX.WAITQUEUE")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-mutex-lock (*mailboxes-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox.lock mbox))) + (mp:with-mutex-lock (lock) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:exemption-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (lock (mailbox.lock mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (mp:with-mutex-lock (lock) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:exemption-wait (mailbox.waitqueue mbox) lock :timeout 0.2)))))) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak :value args)) + +(defimplementation save-image (filename &optional restart-function) + (let ((args `(,filename + ,@(if restart-function + `((:init-function ,restart-function)))))) + (apply #'ext:saveinitmem args))) blob - /dev/null blob + fba9701f544e689d47f2367493588dee0630488e (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/cmucl.lisp @@ -0,0 +1,2483 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; License: Public Domain +;;; +;;;; Introduction +;;; +;;; This is the CMUCL implementation of the `slynk-backend' package. + +(defpackage slynk-cmucl + (:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache + fwrappers)) + +(in-package slynk-cmucl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (let ((min-version #x20c)) + (assert (>= c:byte-fasl-file-version min-version) + () "This file requires CMUCL version ~x or newer" min-version)) + + (require 'gray-streams)) + +(import-slynk-mop-symbols :pcl '(:slot-definition-documentation)) + +(defun slynk-mop:slot-definition-documentation (slot) + (documentation slot t)) + +;;; UTF8 + +(locally (declare (optimize (ext:inhibit-warnings 3))) + ;; Compile and load the utf8 format, if not already loaded. + (stream::find-external-format :utf-8)) + +(defimplementation string-to-utf8 (string) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:string-to-octets string :external-format ef))) + +(defimplementation utf8-to-string (octets) + (let ((ef (load-time-value (stream::find-external-format :utf-8) t))) + (stream:octets-to-string octets :external-format ef))) + + +;;;; TCP server +;;; +;;; In CMUCL we support all communication styles. By default we use +;;; `:SIGIO' because it is the most responsive, but it's somewhat +;;; dangerous: CMUCL is not in general "signal safe", and you don't +;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and +;;; `:SPAWN' are reasonable alternatives. + +(defimplementation preferred-communication-style () + :sigio) + +#-(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (let* ((addr (resolve-hostname host)) + (addr (if (not (find-symbol "SOCKET-ERROR" :ext)) + (ext:htonl addr) + addr))) + (ext:create-inet-listener port :stream :reuse-address t :host addr + :backlog (or backlog 5)))) + +;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix. +#+(or darwin mips) +(defimplementation create-socket (host port &key backlog) + (declare (ignore host)) + (ext:create-inet-listener port :stream :reuse-address t)) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (let ((fd (socket-fd socket))) + (sys:invalidate-descriptor fd) + (ext:close-socket fd))) + +(defimplementation accept-connection (socket &key + external-format buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (ext:accept-tcp-connection socket) + (ecase buffering + ((t) :full) + (:line :line) + ((nil) :none)) + external-format)) + +;;;;; Sockets + +(defimplementation socket-fd (socket) + "Return the filedescriptor for the socket represented by SOCKET." + (etypecase socket + (fixnum socket) + (sys:fd-stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of HOSTNAME as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 "iso-latin-1-unix") + #+unicode + (:utf-8 "utf-8-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd buffering external-format) + "Create a new input/output fd-stream for FD." + (cond (external-format + (sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering buffering + :external-format external-format)) + (t + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8) + :buffering buffering)))) + +(defimplementation make-fd-stream (fd external-format) + (make-socket-io-stream fd :full external-format)) + +(defimplementation dup (fd) + (multiple-value-bind (clone error) (unix:unix-dup fd) + (unless clone (error "dup failed: ~a" (unix:get-unix-error-msg error))) + clone)) + +(defimplementation command-line-args () + ext:*command-line-strings*) + +(defimplementation exec-image (image-file args) + (multiple-value-bind (ok error) + (unix:unix-execve (car (command-line-args)) + (list* (car (command-line-args)) + "-core" image-file + "-noinit" + args)) + (error "~a" (unix:get-unix-error-msg error)) + ok)) + +;;;;; Signal-driven I/O + +(defimplementation install-sigint-handler (function) + (sys:enable-interrupt :sigint (lambda (signal code scp) + (declare (ignore signal code scp)) + (funcall function)))) + +(defvar *sigio-handlers* '() + "List of (key . function) pairs. +All functions are called on SIGIO, and the key is used for removing +specific functions.") + +(defun reset-sigio-handlers () (setq *sigio-handlers* '())) +;; All file handlers are invalid afer reload. +(pushnew 'reset-sigio-handlers ext:*after-save-initializations*) + +(defun set-sigio-handler () + (sys:enable-interrupt :sigio (lambda (signal code scp) + (sigio-handler signal code scp)))) + +(defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (mapc #'funcall (mapcar #'cdr *sigio-handlers*))) + +(defun fcntl (fd command arg) + "fcntl(2) - manipulate a file descriptor." + (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg) + (cond (ok) + (t (error "fcntl: ~A" (unix:get-unix-error-msg error)))))) + +(defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (fcntl fd unix:f-setown (unix:unix-getpid)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logior old-flags unix:fasync))) + (assert (not (assoc fd *sigio-handlers*))) + (push (cons fd fn) *sigio-handlers*))) + +(defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (when (assoc fd *sigio-handlers*) + (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car)) + (let ((old-flags (fcntl fd unix:f-getfl 0))) + (fcntl fd unix:f-setfl (logandc2 old-flags unix:fasync))) + (sys:invalidate-descriptor fd)) + (assert (not (assoc fd *sigio-handlers*))) + (when (null *sigio-handlers*) + (sys:default-interrupt :sigio)))) + +;;;;; SERVE-EVENT + +(defimplementation add-fd-handler (socket fn) + (let ((fd (socket-fd socket))) + (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn))))) + +(defimplementation remove-fd-handlers (socket) + (sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (let ((ready (remove-if-not #'listen streams))) + (when ready (return ready))) + (when timeout (return nil)) + (multiple-value-bind (in out) (make-pipe) + (let* ((f (constantly t)) + (handlers (loop for s in (cons in (mapcar #'to-fd-stream streams)) + collect (add-one-shot-handler s f)))) + (unwind-protect + (let ((*interrupt-queued-handler* (lambda () + (write-char #\! out)))) + (when (check-sly-interrupts) (return :interrupt)) + (sys:serve-event)) + (mapc #'sys:remove-fd-handler handlers) + (close in) + (close out)))))) + +(defun to-fd-stream (stream) + (etypecase stream + (sys:fd-stream stream) + (synonym-stream + (to-fd-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (to-fd-stream (two-way-stream-input-stream stream))))) + +(defun add-one-shot-handler (stream function) + (let (handler) + (setq handler (sys:add-fd-handler (sys:fd-stream-fd stream) :input + (lambda (fd) + (declare (ignore fd)) + (sys:remove-fd-handler handler) + (funcall function stream)))))) + +(defun make-pipe () + (multiple-value-bind (in out) (unix:unix-pipe) + (values (sys:make-fd-stream in :input t :buffering :none) + (sys:make-fd-stream out :output t :buffering :none)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. +NIL if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (clear-xref-info input-file) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string) + (source-info (list :emacs-buffer buffer + :emacs-buffer-offset position + :emacs-buffer-string string))) + (with-input-from-string (stream string) + (let ((failurep (ext:compile-from-stream stream :source-info + source-info))) + (not failurep)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `SLYNK:COMPILER-CONDITION's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (compiler-condition-message condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of CONDITION." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun compiler-condition-message (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe context information for Emacs." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A ~>~}~%~]~ + ~@[==>~{~&~A~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. +Return a `location' record, or (:error REASON) on failure." + (if (null context) + (note-error-location) + (with-struct (c::compiler-error-context- file-name + original-source + original-source-path) context + (or (locate-compiler-note file-name original-source + (reverse original-source-path)) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (cond (*compile-file-truename* + (make-location (list :file (unix-truename *compile-file-truename*)) + (list :eof))) + (*buffer-name* + (make-location (list :buffer *buffer-name*) + (list :position *buffer-start-position*))) + (t (list :error "No error location available.")))) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + +;;;; XREF +;;; +;;; Cross-reference support is based on the standard CMUCL `XREF' +;;; package. This package has some caveats: XREF information is +;;; recorded during compilation and not preserved in fasl files, and +;;; XREF recording is disabled by default. Redefining functions can +;;; also cause duplicate references to accumulate, but +;;; `slynk-compile-file' will automatically clear out any old records +;;; from the same filename. +;;; +;;; To enable XREF recording, set `c:*record-xref-info*' to true. To +;;; clear out the XREF database call `xref:init-xref-database'. + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls xref:who-calls) +(defxref who-references xref:who-references) +(defxref who-binds xref:who-binds) +(defxref who-sets xref:who-sets) + +;;; More types of XREF information were added since 18e: +;;; + +(defxref who-macroexpands xref:who-macroexpands) +;; XXX +(defimplementation who-specializes (symbol) + (let* ((methods (xref::who-specializes (find-class symbol))) + (locations (mapcar #'method-location methods))) + (mapcar #'list methods locations))) + +(defun xref-results (contexts) + (mapcar (lambda (xref) + (list (xref:xref-context-name xref) + (resolve-xref-location xref))) + contexts)) + +(defun resolve-xref-location (xref) + (let ((name (xref:xref-context-name xref)) + (file (xref:xref-context-file xref)) + (source-path (xref:xref-context-source-path xref))) + (cond ((and file source-path) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (unix-truename file)) + (list :position (1+ position))))) + (file + (make-location (list :file (unix-truename file)) + (list :function-name (string name)))) + (t + `(:error ,(format nil "Unknown source location: ~S ~S ~S " + name file source-path)))))) + +(defun clear-xref-info (namestring) + "Clear XREF notes pertaining to NAMESTRING. +This is a workaround for a CMUCL bug: XREF records are cumulative." + (when c:*record-xref-info* + (let ((filename (truename namestring))) + (dolist (db (list xref::*who-calls* + xref::*who-is-called* + xref::*who-macroexpands* + xref::*who-references* + xref::*who-binds* + xref::*who-sets*)) + (maphash (lambda (target contexts) + ;; XXX update during traversal? + (setf (gethash target db) + (delete filename contexts + :key #'xref:xref-context-file + :test #'equalp))) + db))))) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(labels ((make-stack () (make-array 100 :fill-pointer 0 :adjustable t)) + (map-cpool (code fun) + (declare (type kernel:code-component code) (type function fun)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data code) + do (funcall fun (kernel:code-header-ref code i)))) + + (callees (fun) + (let ((callees (make-stack))) + (map-cpool (vm::find-code-object fun) + (lambda (o) + (when (kernel:fdefn-p o) + (vector-push-extend (kernel:fdefn-function o) + callees)))) + (coerce callees 'list))) + + (callers (fun) + (declare (function fun)) + (let ((callers (make-stack))) + (ext:gc :full t) + ;; scan :dynamic first to avoid the need for even more gcing + (dolist (space '(:dynamic :read-only :static)) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum header) (ignore size)) + (when (= vm:code-header-type header) + (map-cpool obj + (lambda (c) + (when (and (kernel:fdefn-p c) + (eq (kernel:fdefn-function c) fun)) + (vector-push-extend obj callers)))))) + space) + (ext:gc)) + (coerce callers 'list))) + + (entry-points (code) + (loop for entry = (kernel:%code-entry-points code) + then (kernel::%function-next entry) + while entry + collect entry)) + + (guess-main-entry-point (entry-points) + (or (find-if (lambda (fun) + (ext:valid-function-name-p + (kernel:%function-name fun))) + entry-points) + (car entry-points))) + + (fun-dspec (fun) + (list (kernel:%function-name fun) (function-location fun))) + + (code-dspec (code) + (let ((eps (entry-points code)) + (di (kernel:%code-debug-info code))) + (cond (eps (fun-dspec (guess-main-entry-point eps))) + (di (list (c::debug-info-name di) + (debug-info-function-name-location di))) + (t (list (princ-to-string code) + `(:error "No src-loc available"))))))) + (declare (inline map-cpool)) + + (defimplementation list-callers (symbol) + (mapcar #'code-dspec (callers (coerce symbol 'function) ))) + + (defimplementation list-callees (symbol) + (mapcar #'fun-dspec (callees symbol)))) + +(defun test-list-callers (count) + (let ((funsyms '())) + (do-all-symbols (s) + (when (and (fboundp s) + (functionp (symbol-function s)) + (not (macro-function s)) + (not (special-operator-p s))) + (push s funsyms))) + (let ((len (length funsyms))) + (dotimes (i count) + (let ((sym (nth (random len) funsyms))) + (format t "~s -> ~a~%" sym (mapcar #'car (list-callers sym)))))))) + +;; (test-list-callers 100) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the CMUCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `slynk-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. +This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute BODY and return the source-location it returns. +If an error occurs and `*debug-definition-finding*' is false, then +return an error pseudo-location. + +The second return value is NIL if no error occurs, otherwise it is the +condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values `(:error ,(trim-whitespace (princ-to-string c))) + c)))))) + +(defun trim-whitespace (string) + (string-trim #(#\newline #\space #\tab) string)) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for CODE-LOCATION." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for CODE-LOCATION in FILENAME." + (let* ((code-date (di:debug-source-created debug-source)) + (root-number (di:debug-source-root-number debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s root-number))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a CODE-LOCATION from a stream. +This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLY stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for DEBUG-INFO. +Function-name source-locations are a fallback for when precise +positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location? +This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream root) + "Return the byte offset of CODE-LOCATION in STREAM. Extract the +toplevel-form-number and form-number from CODE-LOCATION and use that +to find the position of the corresponding form. + +Finish with STREAM positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (- (di:code-location-top-level-form-offset location) + root)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in STREAM. +TLF-NUMBER is the top-level-form number. +FORM-NUMBER is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of CODE-LOCATION in STRING. +See CODE-LOCATION-STREAM-POSITION." + (with-input-from-string (s string) + (code-location-stream-position code-location s 0))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name) + (template-definitions name) + (primitive-definitions name) + (vm-support-routine-definitions name) + )) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; CMUCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the CMUCL manual for more details. + +(defun function-definitions (name) + "Return definitions for NAME in the \"function namespace\", i.e., +regular functions, generic functions, methods and macros. +NAME can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (function? (and (ext:valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (gf-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for FUNCTION." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + +(defun byte-function-location (fun) + "Return the location of the byte-compiled function FUN." + (etypecase fun + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((di (kernel:%code-debug-info (c::byte-function-component fun)))) + (if di + (debug-info-function-name-location di) + `(:error + ,(format nil "Byte-function without debug-info: ~a" fun))))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fun))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is FUNCTION a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that FUNCTION belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + (let ((ctor (struct-constructor dd))) + (cond (ctor + (function-location (coerce ctor 'function))) + (t + (let ((name (kernel:dd-name dd))) + (multiple-value-bind (location foundp) + (ext:info :source-location :defvar name) + (cond (foundp + (resolve-source-location location)) + (t + (error "No location for defstruct: ~S" name))))))))) + +(defun struct-constructor (dd) + "Return the name of the constructor from a defstruct definition." + (let* ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (if (consp constructor) (car constructor) constructor))) + +;;;;;; Generic functions and methods + +(defun gf-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (pcl::generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (pcl::generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (pcl:method-generic-function method)) + (name (pcl:generic-function-name gf)) + (specializers (pcl:method-specializers method)) + (qualifiers (pcl:method-qualifiers method))) + `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers)))) + +(defun method-location (method) + (typecase method + (pcl::standard-accessor-method + (definition-source-location + (cond ((pcl::definition-source method) + method) + (t + (pcl::slot-definition-class + (pcl::accessor-method-slot-definition method)))) + (pcl::accessor-method-slot-name method))) + (t + (function-location (or (pcl::method-fast-function method) + (pcl:method-function method)))))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (kernel::find-class name nil))) + (etypecase class + (null '()) + (kernel::structure-class + (list (list `(defstruct ,name) (dd-location (find-dd name))))) + #+(or) + (conditions::condition-class + (list (list `(define-condition ,name) + (condition-class-location class)))) + (kernel::standard-class + (list (list `(defclass ,name) + (pcl-class-location (find-class name))))) + ((or kernel::built-in-class + conditions::condition-class + kernel:funcallable-structure-class) + (list (list `(class ,name) (class-location class)))))))) + +(defun pcl-class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (pcl:class-name class))) + +;; FIXME: eval used for backward compatibility. +(defun class-location (class) + (declare (type kernel::class class)) + (let ((name (kernel:%class-name class))) + (multiple-value-bind (loc found?) + (let ((x (ignore-errors + (multiple-value-list + (eval `(ext:info :source-location :class ',name)))))) + (values-list x)) + (cond (found? (resolve-source-location loc)) + (`(:error + ,(format nil "No location recorded for class: ~S" name))))))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((slots (conditions::condition-class-slots class)) + (name (conditions::condition-class-name class))) + (cond ((null slots) + `(:error ,(format nil "No location info for condition: ~A" name))) + (t + ;; Find the class via one of its slot-reader methods. + (let* ((slot (first slots)) + (gf (fdefinition + (first (conditions::condition-slot-readers slot))))) + (method-location + (first + (pcl:compute-applicable-methods-using-classes + gf (list (find-class name)))))))))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun source-location-form-numbers (location) + (c::decode-form-numbers (c::form-numbers-form-numbers location))) + +(defun source-location-tlf-number (location) + (nth-value 0 (source-location-form-numbers location))) + +(defun source-location-form-number (location) + (nth-value 1 (source-location-form-numbers location))) + +(defun resolve-file-source-location (location) + (let ((filename (c::file-source-location-pathname location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + (with-open-file (s filename) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:file ,(unix-truename filename)) + `(:position ,(1+ pos))))))) + +(defun resolve-stream-source-location (location) + (let ((info (c::stream-source-location-user-info location)) + (tlf-number (source-location-tlf-number location)) + (form-number (source-location-form-number location))) + ;; XXX duplication in frame-source-location + (assert (info-from-emacs-buffer-p info)) + (destructuring-bind (&key emacs-buffer emacs-buffer-string + emacs-buffer-offset) info + (with-input-from-string (s emacs-buffer-string) + (let ((pos (form-number-stream-position tlf-number form-number s))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-buffer-offset ,pos))))))) + +;; XXX predicates for 18e backward compatibilty. Remove them when +;; we're 19a only. +(defun file-source-location-p (object) + (when (fboundp 'c::file-source-location-p) + (c::file-source-location-p object))) + +(defun stream-source-location-p (object) + (when (fboundp 'c::stream-source-location-p) + (c::stream-source-location-p object))) + +(defun source-location-p (object) + (or (file-source-location-p object) + (stream-source-location-p object))) + +(defun resolve-source-location (location) + (etypecase location + ((satisfies file-source-location-p) + (resolve-file-source-location location)) + ((satisfies stream-source-location-p) + (resolve-stream-source-location location)))) + +(defun definition-source-location (object name) + (let ((source (pcl::definition-source object))) + (etypecase source + (null + `(:error ,(format nil "No source info for: ~A" object))) + ((satisfies source-location-p) + (resolve-source-location source)) + (pathname + (make-name-in-file-location source name)) + (cons + (destructuring-bind ((dg name) pathname) source + (declare (ignore dg)) + (etypecase pathname + (pathname (make-name-in-file-location pathname (string name))) + (null `(:error ,(format nil "Cannot resolve: ~S" source))))))))) + +(defun setf-definitions (name) + (let ((f (or (ext:info :setf :inverse name) + (ext:info :setf :expander name) + (and (symbolp name) + (fboundp `(setf ,name)) + (fdefinition `(setf ,name)))))) + (if f + `(((setf ,name) ,(function-location (cond ((functionp f) f) + ((macro-function f)) + ((fdefinition f))))))))) + +(defun variable-location (symbol) + (multiple-value-bind (location foundp) + ;; XXX for 18e compatibilty. rewrite this when we drop 18e + ;; support. + (ignore-errors (eval `(ext:info :source-location :defvar ',symbol))) + (if (and foundp location) + (resolve-source-location location) + `(:error ,(format nil "No source info for variable ~S" symbol))))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(,(type-of template) + ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + +(defun template-definitions (name) + (let* ((templates (c::backend-template-names c::*backend*)) + (template (gethash name templates))) + (etypecase template + (null) + (c::vop-info + (maybe-make-definition (c::vop-info-generator-function template) + (type-of template) name))))) + +;; for cases like: (%primitive NAME ...) +(defun primitive-definitions (name) + (let ((csym (find-symbol (string name) 'c))) + (and csym + (not (eq csym name)) + (template-definitions csym)))) + +(defun vm-support-routine-definitions (name) + (let ((sr (c::backend-support-routines c::*backend*)) + (name (find-symbol (string name) 'c))) + (and name + (slot-exists-p sr name) + (maybe-make-definition (slot-value sr name) + (find-symbol (string 'vm-support-routine) 'c) + name)))) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unkown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (etypecase fun + (function (function-arglist fun)) + (symbol (function-arglist (or (macro-function fun) + (symbol-function fun)))))) + +(defun function-arglist (fun) + (let ((arglist + (cond ((eval:interpreted-function-p fun) + (eval:interpreted-function-arglist fun)) + ((pcl::generic-function-p fun) + (pcl:generic-function-lambda-list fun)) + ((c::byte-function-or-closure-p fun) + (byte-code-function-arglist fun)) + ((kernel:%function-arglist (kernel:%function-self fun)) + (handler-case (read-arglist fun) + (error () :not-available))) + ;; this should work both for compiled-debug-function + ;; and for interpreted-debug-function + (t + (handler-case (debug-function-arglist + (di::function-debug-function fun)) + (di:unhandled-condition () :not-available)))))) + (check-type arglist (or list (member :not-available))) + arglist)) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((pcl::generic-function-p function) + (pcl::generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + +;;; A simple case: the arglist is available as a string that we can +;;; `read'. + +(defun read-arglist (fn) + "Parse the arglist-string of the function object FN." + (let ((string (kernel:%function-arglist + (kernel:%function-self fn))) + (package (find-package + (c::compiled-debug-info-package + (kernel:%code-debug-info + (vm::find-code-object fn)))))) + (with-standard-io-syntax + (let ((*package* (or package *package*))) + (read-from-string string))))) + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. +A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + +;;; Deriving arglists for byte-compiled functions: +;;; +(defun byte-code-function-arglist (fn) + ;; There doesn't seem to be much arglist information around for + ;; byte-code functions. Use the arg-count and return something like + ;; (arg0 arg1 ...) + (etypecase fn + (c::simple-byte-function + (loop for i from 0 below (c::simple-byte-function-num-args fn) + collect (make-arg-symbol i))) + (c::hairy-byte-function + (hairy-byte-function-arglist fn)) + (c::byte-closure + (byte-code-function-arglist (c::byte-closure-function fn))))) + +(defun make-arg-symbol (i) + (make-symbol (format nil "~A~D" (string 'arg) i))) + +;;; A "hairy" byte-function is one that takes a variable number of +;;; arguments. `hairy-byte-function' is a type from the bytecode +;;; interpreter. +;;; +(defun hairy-byte-function-arglist (fn) + (let ((counter -1)) + (flet ((next-arg () (make-arg-symbol (incf counter)))) + (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p + keywords-p keywords) fn + (let ((arglist '()) + (optional (- max-args min-args))) + ;; XXX isn't there a better way to write this? + ;; (Looks fine to me. -luke) + (dotimes (i min-args) + (push (next-arg) arglist)) + (when (plusp optional) + (push '&optional arglist) + (dotimes (i optional) + (push (next-arg) arglist))) + (when rest-arg-p + (push '&rest arglist) + (push (next-arg) arglist)) + (when keywords-p + (push '&key arglist) + (loop for (key _ __) in keywords + do (push key arglist)) + (when (eq keywords-p :allow-others) + (push '&allow-other-keys arglist))) + (nreverse arglist)))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +(defimplementation compiler-macroexpand-1 (form &optional env) + (ext:compiler-macroexpand-1 form env)) + +(defimplementation compiler-macroexpand (form &optional env) + (ext:compiler-macroexpand form env)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + "cmucl") + +(defimplementation quit-lisp () + (ext::quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; slynk-source-path-parser + + +;;;; Debugging + +(defvar *sly-db-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (unix:unix-sigsetmask 0) + (let* ((*sly-db-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sly-db-condition + :original-condition condition)))) + (unwind-protect + (progn + #+(or)(sys:scrub-control-stack) + (funcall debugger-loop-fn)) + #+(or)(sys:scrub-control-stack) + )))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sly-db-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (let ((frame (nth-frame index))) + (cond ((foreign-frame-p frame) (foreign-frame-source-location frame)) + ((code-location-source-location (di:frame-code-location frame)))))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let ((loc (di:frame-code-location frame))) + (remove-if + (lambda (v) + (not (eq (di:debug-variable-validity v loc) :valid))) + (di::debug-function-debug-variables (di:frame-debug-function frame))))) + +(defun debug-var-value (var frame) + (let* ((loc (di:frame-code-location frame)) + (validity (di:debug-variable-validity var loc))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let ((frame (nth-frame index))) + (loop for v across (frame-debug-vars frame) + collect (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (dbg-fun (di:frame-debug-function frame))) + (typecase dbg-fun + (di::compiled-debug-function + (let* ((comp (di::compiled-debug-function-component dbg-fun)) + (dbg-info (kernel:%code-debug-info comp))) + (typecase dbg-info + (c::compiled-debug-info + (find-package (c::compiled-debug-info-package dbg-info))))))))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (string 'find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of CMUCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sly-db-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext) + (let ((*breakpoint-sigcontext* sigcontext) + (*breakpoint-pc* offset)) + (call-next-function))) +(set-fwrappers 'di::handle-breakpoint '()) +(fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:sigcontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:sigcontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; CMUCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (speed 0))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in +;; newer versions of CMUCL (after ~March 2005). +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di))) + (cond (sym (funcall sym sigcontext)) + (t (funcall 'di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +(defimplementation condition-extras (condition) + (typecase condition + (breakpoint + ;; pop up the source buffer + `((:show-frame-source 0))) + (t '()))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +(defimplementation sly-db-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + (di::interpreted-debug-function -1) + (di::bogus-debug-function + #-x86 + (let* ((real (di::frame-real-frame (di::frame-up frame))) + (fp (di::frame-pointer real))) + ;;#+(or) + (progn + (format *debug-io* "Frame-real-frame = ~S~%" real) + (format *debug-io* "fp = ~S~%" fp) + (format *debug-io* "lra = ~S~%" + (kernel:stack-ref fp vm::lra-save-offset))) + (values + (sys:int-sap + (- (kernel:get-lisp-obj-address + (kernel:stack-ref fp vm::lra-save-offset)) + (- (ash vm:function-code-offset vm:word-shift) + vm:function-pointer-type))) + 0)) + #+x86 + (let ((fp (di::frame-pointer (di:frame-up frame)))) + (multiple-value-bind (ra ofp) (di::x86-call-context fp) + (declare (ignore ofp)) + (values ra 0)))))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +~8X Stack Pointer +~8X Frame Pointer +~8X Instruction Pointer +~8X Saved Frame Pointer +~8X Saved Instruction Pointer~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + +(defvar *gdb-program-name* + (ext:enumerate-search-list (p "path:gdb") + (when (probe-file p) + (return p)))) + +(defimplementation disassemble-frame (frame-number) + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (cond ((probe-file *gdb-program-name*) + (let ((ip (sys:sap-int (frame-ip frame)))) + (princ (gdb-command "disas 0x~x" ip)))) + (t + (format t "~%[Disassembling bogus frames not implemented]"))))))) + +(defmacro with-temporary-file ((stream filename) &body body) + `(call/temporary-file (lambda (,stream ,filename) . ,body))) + +(defun call/temporary-file (fun) + (let ((name (system::pick-temporary-file-name))) + (unwind-protect + (with-open-file (stream name :direction :output :if-exists :supersede) + (funcall fun stream name)) + (delete-file name)))) + +(defun gdb-command (format-string &rest args) + (let ((str (gdb-exec (format nil + "interpreter-exec mi2 \"attach ~d\"~%~ + interpreter-exec console ~s~%detach" + (getpid) + (apply #'format nil format-string args)))) + (prompt (format nil + #-(and darwin x86) "~%^done~%(gdb) ~%" + #+(and darwin x86) +"~%^done,thread-id=\"1\"~%(gdb) ~%"))) + (subseq str (+ (or (search prompt str) 0) (length prompt))))) + +(defun gdb-exec (cmd) + (with-temporary-file (file filename) + (write-string cmd file) + (force-output file) + (let* ((output (make-string-output-stream)) + ;; gdb on sparc needs to know the executable to find the + ;; symbols. Without this, gdb can't disassemble anything. + ;; NOTE: We assume that the first entry in + ;; lisp::*cmucl-lib* is the bin directory where lisp is + ;; located. If this is not true, we'll have to do + ;; something better to find the lisp executable. + (lisp-path + #+sparc + (list + (namestring + (probe-file + (merge-pathnames "lisp" (car (lisp::parse-unix-search-path + lisp::*cmucl-lib*)))))) + #-sparc + nil) + (proc (ext:run-program *gdb-program-name* + `(,@lisp-path "-batch" "-x" ,filename) + :wait t + :output output))) + (assert (eq (ext:process-status proc) :exited)) + (assert (eq (ext:process-exit-code proc) 0)) + (get-output-stream-string output)))) + +(defun foreign-frame-p (frame) + #-x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (typep (di::frame-debug-function frame) 'di::bogus-debug-function))) + #+x86 + (let ((ip (frame-ip frame))) + (and (sys:system-area-pointer-p ip) + (multiple-value-bind (pc code) + (di::compute-lra-data-from-pc ip) + (declare (ignore pc)) + (not code))))) + +(defun foreign-frame-source-location (frame) + (let ((ip (sys:sap-int (frame-ip frame)))) + (cond ((probe-file *gdb-program-name*) + (parse-gdb-line-info (gdb-command "info line *0x~x" ip))) + (t `(:error "no srcloc available for ~a" frame))))) + +;; The output of gdb looks like: +;; Line 215 of "../../src/lisp/x86-assem.S" +;; starts at address 0x805318c +;; and ends at 0x805318e . +;; The ../../ are fixed up with the "target:" search list which might +;; be wrong sometimes. +(defun parse-gdb-line-info (string) + (with-input-from-string (*standard-input* string) + (let ((w1 (read-word))) + (cond ((equal w1 "Line") + (let ((line (read-word))) + (assert (equal (read-word) "of")) + (let* ((file (read-from-string (read-word))) + (pathname + (or (probe-file file) + (probe-file (format nil "target:lisp/~a" file)) + file))) + (make-location (list :file (unix-truename pathname)) + (list :line (parse-integer line)))))) + (t + `(:error ,string)))))) + +(defun read-word (&optional (stream *standard-input*)) + (peek-char t stream) + (concatenate 'string (loop until (whitespacep (peek-char nil stream)) + collect (read-char stream)))) + +(defun whitespacep (char) + (member char '(#\space #\newline))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:instance-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp "-TYPE" (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list "-TYPE" "VM") + (apropos-list "-TYPE" "BIGNUM")))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (cmucl-inspect o)))) + +(defun cmucl-inspect (o) + (destructuring-bind (text labeledp . parts) (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (1- (kernel:get-closure-length o)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (cmucl-inspect o)) + (t + (call-next-method))))) + +(defmethod emacs-inspect ((o kernel:funcallable-instance)) + (append (label-value-line* + (:function (kernel:%funcallable-instance-function o)) + (:lexenv (kernel:%funcallable-instance-lexenv o)) + (:layout (kernel:%funcallable-instance-layout o))) + (cmucl-inspect o))) + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" + (:newline) + , (with-output-to-string (*standard-output*) + (cond ((c::compiled-debug-info-p (kernel:%code-debug-info o)) + (disassem:disassemble-code-component o)) + ((or + (c::debug-info-p (kernel:%code-debug-info o)) + (consp (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + (c:disassem-byte-component o)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift)))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +#+(or) +(defmethod emacs-inspect ((o array)) + (if (typep o 'simple-array) + (call-next-method) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + +(defmethod emacs-inspect ((o simple-vector)) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (loop for i below (length o) + append (label-value-line i (aref o i))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (declare (optimize (speed 0))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (cmucl-inspect alien)))) + +(defimplementation eval-context (obj) + (cond ((typep (class-of obj) 'structure-class) + (let* ((dd (kernel:layout-info (kernel:layout-of obj))) + (slots (kernel:dd-slots dd))) + (list* (cons '*package* + (symbol-package (if slots + (kernel:dsd-name (car slots)) + (kernel:dd-name dd)))) + (loop for slot in slots collect + (cons (kernel:dsd-name slot) + (funcall (kernel:dsd-accessor slot) obj)))))))) + + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + :methods methods)) + + +;;;; Multiprocessing + +#+mp +(progn + (defimplementation initialize-multiprocessing (continuation) + (mp::init-multi-processing) + (mp:make-process continuation :name "slynk") + ;; Threads magic: this never returns! But top-level becomes + ;; available again. + (unless mp::*idle-process* + (mp::startup-idle-and-top-level-loops))) + + (defimplementation spawn (fn &key name) + (mp:make-process fn :name (or name "Anonymous"))) + + (defvar *thread-id-counter* 0) + + (defimplementation thread-id (thread) + (or (getf (mp:process-property-list thread) 'id) + (setf (getf (mp:process-property-list thread) 'id) + (incf *thread-id-counter*)))) + + (defimplementation find-thread (id) + (find id (all-threads) + :key (lambda (p) (getf (mp:process-property-list p) 'id)))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (mp:process-whostate thread)) + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (copy-list mp:*all-processes*)) + + (defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + + (defimplementation kill-thread (thread) + (mp:destroy-process thread)) + + (defvar *mailbox-lock* (mp:make-lock "mailbox lock")) + + (defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock "process mailbox")) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock-held (*mailbox-lock*) + (or (getf (mp:process-property-list thread) 'mailbox) + (setf (getf (mp:process-property-list thread) 'mailbox) + (make-mailbox))))) + + (defimplementation send (thread message) + (check-sly-interrupts) + (let* ((mbox (mailbox thread))) + (mp:with-lock-held ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + + (defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox mp:*current-process*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (mp:with-lock-held ((mailbox.mutex mbox)) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.5 + (lambda () (some test (mailbox.queue mbox))))))) + + + ) ;; #+mp + + + +;;;; GC hooks +;;; +;;; Display GC messages in the echo area to avoid cluttering the +;;; normal output. +;;; + +;; this should probably not be here, but where else? +(defun background-message (message) + (funcall (find-symbol (string :background-message) :slynk) + message)) + +(defun print-bytes (nbytes &optional stream) + "Print the number NBYTES to STREAM in KB, MB, or GB units." + (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb)))) + (multiple-value-bind (power name) + (loop for ((p1 n1) (p2 n2)) on names + while n2 do + (when (<= (expt 2 p1) nbytes (1- (expt 2 p2))) + (return (values p1 n1)))) + (cond (name + (format stream "~,1F ~A" (/ nbytes (expt 2 power)) name)) + (t + (format stream "~:D bytes" nbytes)))))) + +(defconstant gc-generations 6) + +#+gencgc +(defun generation-stats () + "Return a string describing the size distribution among the generations." + (let* ((alloc (loop for i below gc-generations + collect (lisp::gencgc-stats i))) + (sum (coerce (reduce #'+ alloc) 'float))) + (format nil "~{~3F~^/~}" + (mapcar (lambda (size) (/ size sum)) + alloc)))) + +(defvar *gc-start-time* 0) + +(defun pre-gc-hook (bytes-in-use) + (setq *gc-start-time* (get-internal-real-time)) + (let ((msg (format nil "[Commencing GC with ~A in use.]" + (print-bytes bytes-in-use)))) + (background-message msg))) + +(defun post-gc-hook (bytes-retained bytes-freed trigger) + (declare (ignore trigger)) + (let* ((seconds (/ (- (get-internal-real-time) *gc-start-time*) + internal-time-units-per-second)) + (msg (format nil "[GC done. ~A freed ~A retained ~A ~4F sec]" + (print-bytes bytes-freed) + (print-bytes bytes-retained) + #+gencgc(generation-stats) + #-gencgc"" + seconds))) + (background-message msg))) + +(defun install-gc-hooks () + (setq ext:*gc-notify-before* #'pre-gc-hook) + (setq ext:*gc-notify-after* #'post-gc-hook)) + +(defun remove-gc-hooks () + (setq ext:*gc-notify-before* #'lisp::default-gc-notify-before) + (setq ext:*gc-notify-after* #'lisp::default-gc-notify-after)) + +(defvar *install-gc-hooks* t + "If non-nil install GC hooks") + +(defimplementation emacs-connected () + (when *install-gc-hooks* + (install-gc-hooks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;;In CMUCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + (cond ((fboundp `(method ,@(cdr spec))) + (toggle-trace-aux `(method ,(cdr spec)))) + ;; Man, is this ugly + ((fboundp `(pcl::fast-method ,@(cdr spec))) + (toggle-trace-aux `(pcl::fast-method ,@(cdr spec)))) + (t + (error 'undefined-function :name (cdr spec))))) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))) + ;; doesn't work properly + ;; ((:labels :flet) (toggle-trace-aux (process-fspec spec))) + )) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ((:labels) `(labels ,(third fspec) ,(process-fspec (second fspec)))) + ((:flet) `(flet ,(third fspec) ,(process-fspec (second fspec)))))) + (t + fspec))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) + + +;;; Save image + +(defimplementation save-image (filename &optional restart-function) + (multiple-value-bind (pid error) (unix:unix-fork) + (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error))) + (cond ((= pid 0) + (apply #'ext:save-lisp + filename + (if restart-function + `(:init-function ,restart-function)))) + (t + (let ((status (waitpid pid))) + (destructuring-bind (&key exited? status &allow-other-keys) status + (assert (and exited? (equal status 0)) () + "Invalid exit status: ~a" status))))))) + +(defun waitpid (pid) + (alien:with-alien ((status c-call:int)) + (let ((code (alien:alien-funcall + (alien:extern-alien + waitpid (alien:function c-call:int c-call:int + (* c-call:int) c-call:int)) + pid (alien:addr status) 0))) + (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg))) + (t (assert (= code pid)) + (decode-wait-status status)))))) + +(defun decode-wait-status (status) + (let ((output (with-output-to-string (s) + (call-program (list (process-status-program) + (format nil "~d" status)) + :output s)))) + (read-from-string output))) + +(defun call-program (args &key output) + (destructuring-bind (program &rest args) args + (let ((process (ext:run-program program args :output output))) + (when (not program) (error "fork failed")) + (unless (and (eq (ext:process-status process) :exited) + (= (ext:process-exit-code process) 0)) + (error "Non-zero exit status"))))) + +(defvar *process-status-program* nil) + +(defun process-status-program () + (or *process-status-program* + (setq *process-status-program* + (compile-process-status-program)))) + +(defun compile-process-status-program () + (let ((infile (system::pick-temporary-file-name + "/tmp/process-status~d~c.c"))) + (with-open-file (stream infile :direction :output :if-exists :supersede) + (format stream " +#include +#include +#include +#include +#include + +#define FLAG(value) (value ? \"t\" : \"nil\") + +int main (int argc, char** argv) { + assert (argc == 2); + { + char* endptr = NULL; + char* arg = argv[1]; + long int status = strtol (arg, &endptr, 10); + assert (endptr != arg && *endptr == '\\0'); + printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\" + \" :stopped? %s :stopsig %d)\\n\", + FLAG(WIFEXITED(status)), WEXITSTATUS(status), + FLAG(WIFSIGNALED(status)), WTERMSIG(status), + FLAG(WCOREDUMP(status)), + FLAG(WIFSTOPPED(status)), WSTOPSIG(status)); + fflush (NULL); + return 0; + } +} +") + (finish-output stream)) + (let* ((outfile (system::pick-temporary-file-name)) + (args (list "cc" "-o" outfile infile))) + (warn "Running cc: ~{~a ~}~%" args) + (call-program args :output t) + (delete-file infile) + outfile))) + +;; FIXME: lisp:unicode-complete introduced in version 20d. +#+#.(slynk-backend:with-symbol 'unicode-complete 'lisp) +(defun match-semi-standard (prefix matchp) + ;; Handle the CMUCL's short character names. + (loop for name in lisp::char-name-alist + when (funcall matchp prefix (car name)) + collect (car name))) + +#+#.(slynk-backend:with-symbol 'unicode-complete 'lisp) +(defimplementation character-completion-set (prefix matchp) + (let ((names (lisp::unicode-complete prefix))) + ;; Match prefix against semistandard names. If there's a match, + ;; add it to our list of matches. + (let ((semi-standard (match-semi-standard prefix matchp))) + (when semi-standard + (setf names (append semi-standard names)))) + (setf names (mapcar #'string-capitalize names)) + (loop for n in names + when (funcall matchp prefix n) + collect n))) + +(defimplementation codepoint-length (string) + "Return the number of code points in the string. The string MUST be + a valid UTF-16 string." + (do ((len (length string)) + (index 0 (1+ index)) + (count 0 (1+ count))) + ((>= index len) + count) + (multiple-value-bind (codepoint wide) + (lisp:codepoint string index) + (declare (ignore codepoint)) + (when wide (incf index))))) blob - /dev/null blob + e923a4fbb76183c995fef2324687358aa8f7d2d4 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/corman.lisp @@ -0,0 +1,583 @@ +;;; +;;; slynk-corman.lisp --- Corman Lisp specific code for SLY. +;;; +;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org) +;;; +;;; License +;;; ======= +;;; This software is provided 'as-is', without any express or implied +;;; warranty. In no event will the author be held liable for any damages +;;; arising from the use of this software. +;;; +;;; Permission is granted to anyone to use this software for any purpose, +;;; including commercial applications, and to alter it and redistribute +;;; it freely, subject to the following restrictions: +;;; +;;; 1. The origin of this software must not be misrepresented; you must +;;; not claim that you wrote the original software. If you use this +;;; software in a product, an acknowledgment in the product documentation +;;; would be appreciated but is not required. +;;; +;;; 2. Altered source versions must be plainly marked as such, and must +;;; not be misrepresented as being the original software. +;;; +;;; 3. This notice may not be removed or altered from any source +;;; distribution. +;;; +;;; Notes +;;; ===== +;;; You will need CCL 2.51, and you will *definitely* need to patch +;;; CCL with the patches at +;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLY +;;; will blow up in your face. You should also follow the +;;; instructions on http://www.grumblesmurf.org/lisp/corman-sly. +;;; +;;; The only communication style currently supported is NIL. +;;; +;;; Starting CCL inside emacs (with M-x sly) seems to work for me +;;; with Corman Lisp 2.51, but I have seen random failures with 2.5 +;;; (sometimes it works, other times it hangs on start or hangs when +;;; initializing WinSock) - starting CCL externally and using M-x +;;; sly-connect always works fine. +;;; +;;; Sometimes CCL gets confused and starts giving you random memory +;;; access violation errors on startup; if this happens, try redumping +;;; your image. +;;; +;;; What works +;;; ========== +;;; * Basic editing and evaluation +;;; * Arglist display +;;; * Compilation +;;; * Loading files +;;; * apropos/describe +;;; * Debugger +;;; * Inspector +;;; +;;; TODO +;;; ==== +;;; * More debugger functionality (missing bits: restart-frame, +;;; return-from-frame, disassemble-frame, activate-stepping, +;;; toggle-trace) +;;; * XREF +;;; * Profiling +;;; * More sophisticated communication styles than NIL +;;; + +(in-package :slynk-backend) + +;;; Pull in various needed bits +(require :composite-streams) +(require :sockets) +(require :winbase) +(require :lp) + +(use-package :gs) + +;; MOP stuff + +(defclass slynk-mop:standard-slot-definition () + () + (:documentation + "Dummy class created so that slynk.lisp will compile and load.")) + +(defun named-by-gensym-p (c) + (null (symbol-package (class-name c)))) + +(deftype slynk-mop:eql-specializer () + '(satisfies named-by-gensym-p)) + +(defun slynk-mop:eql-specializer-object (specializer) + (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*) + (loop (multiple-value-bind (more key value) + (next-entry) + (unless more (return nil)) + (when (eq specializer value) + (return key)))))) + +(defun slynk-mop:class-finalized-p (class) + (declare (ignore class)) + t) + +(defun slynk-mop:class-prototype (class) + (make-instance class)) + +(defun slynk-mop:specializer-direct-methods (obj) + (declare (ignore obj)) + nil) + +(defun slynk-mop:generic-function-argument-precedence-order (gf) + (generic-function-lambda-list gf)) + +(defun slynk-mop:generic-function-method-combination (gf) + (declare (ignore gf)) + :standard) + +(defun slynk-mop:generic-function-declarations (gf) + (declare (ignore gf)) + nil) + +(defun slynk-mop:slot-definition-documentation (slot) + (declare (ignore slot)) + (getf slot :documentation nil)) + +(defun slynk-mop:slot-definition-type (slot) + (declare (ignore slot)) + t) + +(import-slynk-mop-symbols :cl '(;; classes + :standard-slot-definition + :eql-specializer + :eql-specializer-object + ;; standard class readers + :class-default-initargs + :class-direct-default-initargs + :class-finalized-p + :class-prototype + :specializer-direct-methods + ;; gf readers + :generic-function-argument-precedence-order + :generic-function-declarations + :generic-function-method-combination + ;; method readers + ;; slot readers + :slot-definition-documentation + :slot-definition-type)) + +;;;; slynk implementations + +;;; Debugger + +(defvar *stack-trace* nil) +(defvar *frame-trace* nil) + +(defstruct frame + name function address debug-info variables) + +(defimplementation call-with-debugging-environment (fn) + (let* ((real-stack-trace (cl::stack-trace)) + (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace + :key #'car))) + (*frame-trace* + (let* ((db::*debug-level* (1+ db::*debug-level*)) + (db::*debug-frame-pointer* (db::stash-ebp + (ct:create-foreign-ptr))) + (db::*debug-max-level* (length real-stack-trace)) + (db::*debug-min-level* 1)) + (cdr (member #'cl:invoke-debugger + (cons + (make-frame :function nil) + (loop for i from db::*debug-min-level* + upto db::*debug-max-level* + until (eq (db::get-frame-function i) + cl::*top-level*) + collect + (make-frame + :function (db::get-frame-function i) + :address (db::get-frame-address i)))) + :key #'frame-function))))) + (funcall fn))) + +(defimplementation compute-backtrace (start end) + (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*))) + collect f)) + +(defimplementation print-frame (frame stream) + (format stream "~S" frame)) + +(defun get-frame-debug-info (frame) + (or (frame-debug-info frame) + (setf (frame-debug-info frame) + (db::prepare-frame-debug-info (frame-function frame) + (frame-address frame))))) + +(defimplementation frame-locals (frame-number) + (let* ((frame (elt *frame-trace* frame-number)) + (info (get-frame-debug-info frame))) + (let ((var-list + (loop for i from 4 below (length info) by 2 + collect `(list :name ',(svref info i) :id 0 + :value (db::debug-filter ,(svref info i)))))) + (let ((vars (eval-in-frame `(list ,@var-list) frame-number))) + (setf (frame-variables frame) vars))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (elt *frame-trace* frame-number))) + (let ((cl::*compiler-environment* (get-frame-debug-info frame))) + (eval form)))) + +(defimplementation frame-var-value (frame-number var) + (let ((vars (frame-variables (elt *frame-trace* frame-number)))) + (when vars + (second (elt vars var))))) + +(defimplementation frame-source-location (frame-number) + (fspec-location (frame-function (elt *frame-trace* frame-number)))) + +(defun break (&optional (format-control "Break") &rest format-arguments) + (with-simple-restart (continue "Return from BREAK.") + (let ();(*debugger-hook* nil)) + (let ((condition + (make-condition 'simple-condition + :format-control format-control + :format-arguments format-arguments))) + ;;(format *debug-io* ";;; User break: ~A~%" condition) + (invoke-debugger condition)))) + nil) + +;;; Socket communication + +(defimplementation create-socket (host port &key backlog) + (sockets:start-sockets) + (sockets:make-server-socket :host host :port port)) + +(defimplementation local-port (socket) + (sockets:socket-port socket)) + +(defimplementation close-socket (socket) + (close socket)) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering timeout external-format)) + (sockets:make-socket-stream (sockets:accept-socket socket))) + +;;; Misc + +(defimplementation preferred-communication-style () + nil) + +(defimplementation getpid () + ccl:*current-process-id*) + +(defimplementation lisp-implementation-type-name () + "cormanlisp") + +(defimplementation quit-lisp () + (sockets:stop-sockets) + (win32:exitprocess 0)) + +(defimplementation set-default-directory (directory) + (setf (ccl:current-directory) directory) + (directory-namestring (setf *default-pathname-defaults* + (truename (merge-pathnames directory))))) + +(defimplementation default-directory () + (directory-namestring (ccl:current-directory))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (ccl:macroexpand-all form)) + +;;; Documentation + +(defun fspec-location (fspec) + (when (symbolp fspec) + (setq fspec (symbol-function fspec))) + (let ((file (ccl::function-source-file fspec))) + (if file + (handler-case + (let ((truename (truename + (merge-pathnames file + ccl:*cormanlisp-directory*)))) + (make-location (list :file (namestring truename)) + (if (ccl::function-source-line fspec) + (list :line + (1+ (ccl::function-source-line fspec))) + (list :function-name + (princ-to-string + (function-name fspec)))))) + (error (c) (list :error (princ-to-string c)))) + (list :error (format nil "No source information available for ~S" + fspec))))) + +(defimplementation find-definitions (name) + (list (list name (fspec-location name)))) + +(defimplementation arglist (name) + (handler-case + (cond ((and (symbolp name) + (macro-function name)) + (ccl::macro-lambda-list (symbol-function name))) + (t + (when (symbolp name) + (setq name (symbol-function name))) + (if (eq (class-of name) cl::the-class-standard-gf) + (generic-function-lambda-list name) + (ccl:function-lambda-list name)))) + (error () :not-available))) + +(defimplementation function-name (fn) + (handler-case (getf (cl::function-info-list fn) 'cl::function-name) + (error () nil))) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind &optional (sym symbol)) + (or (documentation sym kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :function (if (fboundp symbol) + (doc 'function))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol namespace) + (ecase namespace + (:variable + (describe symbol)) + ((:function :generic-function) + (describe (symbol-function symbol))) + (:class + (describe (find-class symbol))))) + +;;; Compiler + +(defvar *buffer-name* nil) +(defvar *buffer-position*) +(defvar *buffer-string*) +(defvar *compile-filename* nil) + +;; FIXME +(defimplementation call-with-compilation-hooks (FN) + (handler-bind ((error (lambda (c) + (signal 'compiler-condition + :original-condition c + :severity :warning + :message (format nil "~A" c) + :location + (cond (*buffer-name* + (make-location + (list :buffer *buffer-name*) + (list :offset *buffer-position* 0))) + (*compile-filename* + (make-location + (list :file *compile-filename*) + (list :position 1))) + (t + (list :error "No location"))))))) + (funcall fn))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore external-format policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (multiple-value-bind (output-file warnings? failure?) + (compile-file input-file :output-file output-file) + (values output-file warnings? + (or failure? (and load-p (load output-file)))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-position* position) + (*buffer-string* string)) + (funcall (compile nil (read-from-string + (format nil "(~S () ~A)" 'lambda string)))) + t))) + +;;;; Inspecting + +;; Hack to make slynk.lisp load, at least +(defclass file-stream ()) + +(defun comma-separated (list &optional (callback (lambda (v) + `(:value ,v)))) + (butlast (loop for e in list + collect (funcall callback e) + collect ", "))) + +(defmethod emacs-inspect ((class standard-class)) + `("Name: " + (:value ,(class-name class)) + (:newline) + "Super classes: " + ,@(comma-separated (slynk-mop:class-direct-superclasses class)) + (:newline) + "Direct Slots: " + ,@(comma-separated + (slynk-mop:class-direct-slots class) + (lambda (slot) + `(:value ,slot + ,(princ-to-string + (slynk-mop:slot-definition-name slot))))) + (:newline) + "Effective Slots: " + ,@(if (slynk-mop:class-finalized-p class) + (comma-separated + (slynk-mop:class-slots class) + (lambda (slot) + `(:value ,slot ,(princ-to-string + (slynk-mop:slot-definition-name slot))))) + '("#")) + (:newline) + ,@(when (documentation class t) + `("Documentation:" (:newline) ,(documentation class t) (:newline))) + "Sub classes: " + ,@(comma-separated (slynk-mop:class-direct-subclasses class) + (lambda (sub) + `(:value ,sub ,(princ-to-string (class-name sub))))) + (:newline) + "Precedence List: " + ,@(if (slynk-mop:class-finalized-p class) + (comma-separated + (slynk-mop:class-precedence-list class) + (lambda (class) + `(:value ,class + ,(princ-to-string (class-name class))))) + '("#")) + (:newline))) + +(defmethod emacs-inspect ((slot cons)) + ;; Inspects slot definitions + (if (eq (car slot) :name) + `("Name: " (:value ,(slynk-mop:slot-definition-name slot)) + (:newline) + ,@(when (slynk-mop:slot-definition-documentation slot) + `("Documentation:" + (:newline) + (:value + ,(slynk-mop:slot-definition-documentation slot)) + (:newline))) + "Init args: " (:value + ,(slynk-mop:slot-definition-initargs slot)) + (:newline) + "Init form: " + ,(if (slynk-mop:slot-definition-initfunction slot) + `(:value ,(slynk-mop:slot-definition-initform slot)) + "#") (:newline) + "Init function: " + (:value ,(slynk-mop:slot-definition-initfunction slot)) + (:newline)) + (call-next-method))) + +(defmethod emacs-inspect ((pathname pathnames::pathname-internal)) + (list* (if (wild-pathname-p pathname) + "A wild pathname." + "A pathname.") + '(:newline) + (append (label-value-line* + ("Namestring" (namestring pathname)) + ("Host" (pathname-host pathname)) + ("Device" (pathname-device pathname)) + ("Directory" (pathname-directory pathname)) + ("Name" (pathname-name pathname)) + ("Type" (pathname-type pathname)) + ("Version" (pathname-version pathname))) + (unless (or (wild-pathname-p pathname) + (not (probe-file pathname))) + (label-value-line "Truename" (truename pathname)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((cl::structurep o) (inspect-structure o)) + (t (call-next-method)))) + +(defun inspect-structure (o) + (let* ((template (cl::uref o 1)) + (num-slots (cl::struct-template-num-slots template))) + (cond ((symbolp template) + (loop for i below num-slots + append (label-value-line i (cl::uref o (+ 2 i))))) + (t + (loop for i below num-slots + append (label-value-line (elt template (+ 6 (* i 5))) + (cl::uref o (+ 2 i)))))))) + + +;;; Threads + +(require 'threads) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + (lock (make-instance 'threads:critical-section)) + (queue '() :type list)) + +(defvar *mailbox-lock* (make-instance 'threads:critical-section)) +(defvar *mailboxes* (list)) + +(defmacro with-lock (lock &body body) + `(threads:with-synchronization (threads:cs ,lock) + ,@body)) + +(defimplementation spawn (fun &key name) + (declare (ignore name)) + (th:create-thread + (lambda () + (handler-bind ((serious-condition #'invoke-debugger)) + (unwind-protect (funcall fun) + (with-lock *mailbox-lock* + (setq *mailboxes* (remove cormanlisp:*current-thread-id* + *mailboxes* :key #'mailbox.thread)))))))) + +(defimplementation thread-id (thread) + thread) + +(defimplementation find-thread (thread) + (if (thread-alive-p thread) + thread)) + +(defimplementation thread-alive-p (thread) + (if (threads:thread-handle thread) t nil)) + +(defimplementation current-thread () + cormanlisp:*current-thread-id*) + +;; XXX implement it +(defimplementation all-threads () + '()) + +;; XXX something here is broken +(defimplementation kill-thread (thread) + (threads:terminate-thread thread 'killed)) + +(defun mailbox (thread) + (with-lock *mailbox-lock* + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (with-lock (mailbox.lock mbox) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(defimplementation receive () + (let ((mbox (mailbox cormanlisp:*current-thread-id*))) + (loop + (with-lock (mailbox.lock mbox) + (when (mailbox.queue mbox) + (return (pop (mailbox.queue mbox))))) + (sleep 0.1)))) + + +;;; This is probably not good, but it WFM +(in-package :common-lisp) + +(defvar *old-documentation* #'documentation) +(defun documentation (thing &optional (type 'function)) + (if (symbolp thing) + (funcall *old-documentation* thing type) + (values))) + +(defmethod print-object ((restart restart) stream) + (if (or *print-escape* + *print-readably*) + (print-unreadable-object (restart stream :type t :identity t) + (princ (restart-name restart) stream)) + (when (functionp (restart-report-function restart)) + (funcall (restart-report-function restart) stream)))) blob - /dev/null blob + 9ebeff5886a36e134073a0c862567822cb3378e3 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/ecl.lisp @@ -0,0 +1,1093 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-ecl.lisp --- SLY backend for ECL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage slynk-ecl + (:use cl slynk-backend)) + +(in-package slynk-ecl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ecl-version () + (let ((version (find-symbol "+ECL-VERSION-NUMBER+" :EXT))) + (if version + (symbol-value version) + 0))) + (when (< (ecl-version) 100301) + (error "~&IMPORTANT:~% ~ + The version of ECL you're using (~A) is too old.~% ~ + Please upgrade to at least 10.3.1.~% ~ + Sorry for the inconvenience.~%~%" + (lisp-implementation-version)))) + +;; Hard dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sockets)) + +;; Soft dependencies. +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (probe-file "sys:profile.fas") + (require :profile) + (pushnew :profile *features*)) + (when (probe-file "sys:serve-event.fas") + (require :serve-event) + (pushnew :serve-event *features*))) + +(declaim (optimize (debug 3))) + +;;; Slynk-mop + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import-slynk-mop-symbols + :clos + (and (< (ecl-version) 121201) + `(:eql-specializer + :eql-specializer-object + :generic-function-declarations + :specializer-direct-methods + ,@(unless (fboundp 'clos:compute-applicable-methods-using-classes) + '(:compute-applicable-methods-using-classes)))))) + +(defimplementation gray-package-name () + "GRAY") + + +;;;; UTF8 + +;;; Convert the string STRING to a (simple-array (unsigned-byte 8)). +;;; +;;; string-to-utf8 (string) + +;;; Convert the (simple-array (unsigned-byte 8)) OCTETS to a string. +;;; +;;; utf8-to-string (octets) + + +;;;; TCP Server + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t + :input t + :buffering (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line)) + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format)) + +;;; Call FN whenever SOCKET is readable. +;;; +;;; add-sigio-handler (socket fn) + +;;; Remove all sigio handlers for SOCKET. +;;; +;;; remove-sigio-handlers (socket) + +;;; Call FN when Lisp is waiting for input and SOCKET is readable. +;;; +;;; add-fd-handler (socket fn) + +;;; Remove all fd-handlers for SOCKET. +;;; +;;; remove-fd-handlers (socket) + +(defimplementation preferred-communication-style () + (cond + ((member :threads *features*) :spawn) + ((member :windows *features*) nil) + (t #|:fd-handler|# nil))) + +;;; Set the 'stream 'timeout. The timeout is either the real number +;;; specifying the timeout in seconds or 'nil for no timeout. +;;; +;;; set-stream-timeout (stream timeout) + + +;;; Hook called when the first connection from Emacs is established. +;;; Called from the INIT-FN of the socket server that accepts the +;;; connection. +;;; +;;; This is intended for setting up extra context, e.g. to discover +;;; that the calling thread is the one that interacts with Emacs. +;;; +;;; emacs-connected () + + +;;;; Unix Integration + +(defimplementation getpid () + (si:getpid)) + +;;; Call FUNCTION on SIGINT (instead of invoking the debugger). +;;; Return old signal handler. +;;; +;;; install-sigint-handler (function) + +;;; XXX! +;;; If ECL is built with thread support, it'll spawn a helper thread +;;; executing the SIGINT handler. We do not want to BREAK into that +;;; helper but into the main thread, though. This is coupled with the +;;; current choice of NIL as communication-style in so far as ECL's +;;; main-thread is also the Sly's REPL thread. + +(defun make-interrupt-handler (real-handler) + #+threads + (let ((main-thread (find 'si:top-level (mp:all-processes) + :key #'mp:process-name))) + #'(lambda (&rest args) + (declare (ignore args)) + (mp:interrupt-process main-thread real-handler))) + #-threads + #'(lambda (&rest args) + (declare (ignore args)) + (funcall real-handler))) + +(defimplementation call-with-user-break-handler (real-handler function) + (let ((old-handler #'si:terminal-interrupt)) + (setf (symbol-function 'si:terminal-interrupt) + (make-interrupt-handler real-handler)) + (unwind-protect (funcall function) + (setf (symbol-function 'si:terminal-interrupt) old-handler)))) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; Default implementation is fine. +;;; +;;; lisp-implementation-type-name +;;; lisp-implementation-program + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (two-way-stream (socket-fd (two-way-stream-input-stream socket))) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (si:file-stream-fd socket)))) + +;;; Create a character stream for the file descriptor FD. This +;;; interface implementation requires either `ffi:c-inline' or has to +;;; wait for the exported interface. +;;; +;;; make-fd-stream (socket-stream) + +;;; Duplicate a file descriptor. If the syscall fails, signal a +;;; condition. See dup(2). This interface requiers `ffi:c-inline' or +;;; has to wait for the exported interface. +;;; +;;; dup (fd) + +;;; Does not apply to ECL which doesn't dump images. +;;; +;;; exec-image (image-file args) + +(defimplementation command-line-args () + (ext:command-args)) + + +;;;; pathnames + +;;; Return a pathname for FILENAME. +;;; A filename in Emacs may for example contain asterisks which should not +;;; be translated to wildcards. +;;; +;;; filename-to-pathname (filename) + +;;; Return the filename for PATHNAME. +;;; +;;; pathname-to-filename (pathname) + +(defimplementation default-directory () + (namestring (ext:getcwd))) + +(defimplementation set-default-directory (directory) + (ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*. + (default-directory)) + + +;;; Call FN with hooks to handle special syntax. Can we use it for +;;; `ffi:c-inline' to be handled as C/C++ code? +;;; +;;; call-with-syntax-hooks + +;;; Return a suitable initial value for SLYNK:*READTABLE-ALIST*. +;;; +;;; default-readtable-alist + + +;;;; Packages + +#+package-local-nicknames +(defimplementation package-local-nicknames (package) + (ext:package-local-nicknames package)) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) + +(defun signal-compiler-condition (&rest args) + (apply #'signal 'compiler-condition args)) + +#-ecl-bytecmp +(defun handle-compiler-message (condition) + ;; ECL emits lots of noise in compiler-notes, like "Invoking + ;; external command". + (unless (typep condition 'c::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (c:compiler-fatal-error :error) + (c:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +#-ecl-bytecmp +(defun condition-location (condition) + (let ((file (c:compiler-message-file condition)) + (position (c:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) + +(defimplementation call-with-compilation-hooks (function) + #+ecl-bytecmp + (funcall function) + #-ecl-bytecmp + (handler-bind ((c:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defvar *tmpfile-map* (make-hash-table :test #'equal)) + +(defun note-buffer-tmpfile (tmp-file buffer-name) + ;; EXT:COMPILED-FUNCTION-FILE below will return a namestring. + (let ((tmp-namestring (namestring (truename tmp-file)))) + (setf (gethash tmp-namestring *tmpfile-map*) buffer-name) + tmp-namestring)) + +(defun tmpfile-to-buffer (tmp-file) + (gethash tmp-file *tmpfile-map*)) + +(defimplementation slynk-compile-string + (string &key buffer position filename line column policy) + (declare (ignore line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) ; for compilation hooks + (*buffer-start-position* position)) + (let ((tmp-file (si:mkstemp "TMP:ecl-slynk-tmpfile-")) + (fasl-file) + (warnings-p) + (failure-p)) + (unwind-protect + (with-open-file (tmp-stream tmp-file :direction :output + :if-exists :supersede) + (write-string string tmp-stream) + (finish-output tmp-stream) + (multiple-value-setq (fasl-file warnings-p failure-p) + (compile-file tmp-file + :load t + :source-truename (or filename + (note-buffer-tmpfile tmp-file buffer)) + :source-offset (1- position)))) + (when (probe-file tmp-file) + (delete-file tmp-file)) + (when fasl-file + (delete-file fasl-file))) + (not failure-p))))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *external-format-to-coding-system* + '((:latin-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (ext:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, ECL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SLYNK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + +;;; Default implementation is fine +;;; +;;; guess-external-format + + +;;;; Streams + +;;; Implemented in `gray' +;;; +;;; make-output-stream +;;; make-input-stream + + +;;;; Documentation + +(defimplementation arglist (name) + (multiple-value-bind (arglist foundp) + (ext:function-lambda-list name) + (if foundp arglist :not-available))) + +(defimplementation type-specifier-p (symbol) + (or (subtypep nil symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defimplementation function-name (f) + (typecase f + (generic-function (clos:generic-function-name f)) + (function (si:compiled-function-name f)))) + +;;; Default implementation is fine (CL). +;;; +;;; valid-function-name-p (form) + +#+walker +(defimplementation macroexpand-all (form &optional env) + (walker:macroexpand-all form env)) + +;;; Default implementation is fine. +;;; +;;; compiler-macroexpand-1 +;;; compiler-macroexpand + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((frob (type boundp) + (when (funcall boundp symbol) + (let ((doc (describe-definition symbol type))) + (setf result (list* type doc result)))))) + (frob :VARIABLE #'boundp) + (frob :FUNCTION #'fboundp) + (frob :CLASS (lambda (x) (find-class x nil)))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + + +;;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(lambda (condition old-hook) + ;; Regard *debugger-hook* if set by user. + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setq ext:*invoke-debugger-hook* (make-invoke-debugger-hook function))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall fun))) + +(defvar *backtrace* '()) + +;;; Commented out; it's not clear this is a good way of doing it. In +;;; particular because it makes errors stemming from this file harder +;;; to debug, and given the "young" age of ECL's slynk backend, that's +;;; a bad idea. +;;; +;;; Also before thinking whether to uncomment this consider that SLY +;;; might not be loaded with slynk-loader.lisp at all. + +;; (defun in-slynk-package-p (x) +;; (and +;; (symbolp x) +;; (member (symbol-package x) +;; (list #.(find-package :slynk) +;; #.(find-package :slynk-backend) +;; #.(ignore-errors (find-package :slynk-mop)) +;; #.(ignore-errors (find-package :slynk-loader)))) +;; t)) + +;; (defun is-slynk-source-p (name) +;; (setf name (pathname name)) +;; (pathname-match-p +;; name +;; (make-pathname :defaults slynk-loader::*source-directory* +;; :name (pathname-name name) +;; :type (pathname-type name) +;; :version (pathname-version name)))) + +;; (defun is-ignorable-fun-p (x) +;; (or +;; (in-slynk-package-p (frame-name x)) +;; (multiple-value-bind (file position) +;; (ignore-errors (si::bc-file (car x))) +;; (declare (ignore position)) +;; (if file (is-slynk-source-p file))))) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* ((*ihs-top* (ihs-top)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* until *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (si::fixnump name) + (push name (third x))))))) + ;; (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *backtrace* (nreverse *backtrace*)) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation compute-backtrace (start end) + (subseq *backtrace* start + (and (numberp end) + (min end (length *backtrace*))))) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::bc-file fun) + (when file + (make-file-location file position)))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record (remove-if-not #'consp frame)) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (si::fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (format stream "~A" (first frame))) + +;;; Is the frame FRAME restartable?. +;;; Return T if `restart-frame' can safely be called on the frame. +;;; +;;; frame-restartable-p (frame) + +(defimplementation frame-source-location (frame-number) + (let ((frame (elt *backtrace* frame-number))) + (or (nth-value 1 (frame-function frame)) + (make-error-location "Unknown source location for ~A." (car frame))))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env + (elt *backtrace* frame-number))) + collect (list :name name :id 0 :value value))) + +(defimplementation frame-var-value (frame-number var-number) + (destructuring-bind (name . value) + (elt + (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + var-number) + (declare (ignore name)) + value)) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-function (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-with-env form env))) + +;;; frame-package +;;; frame-call +;;; return-from-frame +;;; restart-frame +;;; print-condition +;;; condition-extras + +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +;;; active-stepping +;;; sldb-break-on-return +;;; sldb-break-at-start +;;; sldb-stepper-condition-p +;;; sldb-setp-into +;;; sldb-step-next +;;; sldb-step-out + + +;;;; Definition finding + +(defvar +TAGS+ (namestring + (merge-pathnames "TAGS" (translate-logical-pathname "SYS:")))) + +(defun make-file-location (file file-position) + ;; File positions in CL start at 0, but Emacs' buffer positions + ;; start at 1. We specify (:ALIGN T) because the positions comming + ;; from ECL point at right after the toplevel form appearing before + ;; the actual target toplevel form; (:ALIGN T) will DTRT in that case. + (make-location `(:file ,(namestring (translate-logical-pathname file))) + `(:position ,(1+ file-position)) + `(:align t))) + +(defun make-buffer-location (buffer-name start-position &optional (offset 0)) + (make-location `(:buffer ,buffer-name) + `(:offset ,start-position ,offset) + `(:align t))) + +(defun make-TAGS-location (&rest tags) + (make-location `(:etags-file ,+TAGS+) + `(:tag ,@tags))) + +(defimplementation find-definitions (name) + (let ((annotations (ext:get-annotation name 'si::location :all))) + (cond (annotations + (loop for annotation in annotations + collect (destructuring-bind (dspec file . pos) annotation + `(,dspec ,(make-file-location file pos))))) + (t + (mapcan #'(lambda (type) (find-definitions-by-type name type)) + (classify-definition-name name)))))) + +(defun classify-definition-name (name) + (let ((types '())) + (when (fboundp name) + (cond ((special-operator-p name) + (push :special-operator types)) + ((macro-function name) + (push :macro types)) + ((typep (fdefinition name) 'generic-function) + (push :generic-function types)) + ((si:mangle-name name t) + (push :c-function types)) + (t + (push :lisp-function types)))) + (when (boundp name) + (cond ((constantp name) + (push :constant types)) + (t + (push :global-variable types)))) + types)) + +(defun find-definitions-by-type (name type) + (ecase type + (:lisp-function + (when-let (loc (source-location (fdefinition name))) + (list `((defun ,name) ,loc)))) + (:c-function + (when-let (loc (source-location (fdefinition name))) + (list `((c-source ,name) ,loc)))) + (:generic-function + (loop for method in (clos:generic-function-methods (fdefinition name)) + for specs = (clos:method-specializers method) + for loc = (source-location method) + when loc + collect `((defmethod ,name ,specs) ,loc))) + (:macro + (when-let (loc (source-location (macro-function name))) + (list `((defmacro ,name) ,loc)))) + (:constant + (when-let (loc (source-location name)) + (list `((defconstant ,name) ,loc)))) + (:global-variable + (when-let (loc (source-location name)) + (list `((defvar ,name) ,loc)))) + (:special-operator))) + +;;; FIXME: There ought to be a better way. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun c-function-name-p (name) + (and (symbolp name) (si:mangle-name name t) t)) + (defun c-function-p (object) + (and (functionp object) + (let ((fn-name (function-name object))) + (and fn-name (c-function-name-p fn-name)))))) + +(deftype c-function () + `(satisfies c-function-p)) + +(defun assert-source-directory () + (unless (probe-file #P"SRC:") + (error "ECL's source directory ~A does not exist. ~ + You can specify a different location via the environment ~ + variable `ECLSRCDIR'." + (namestring (translate-logical-pathname #P"SYS:"))))) + +(defun assert-TAGS-file () + (unless (probe-file +TAGS+) + (error "No TAGS file ~A found. It should have been installed with ECL." + +TAGS+))) + +(defun package-names (package) + (cons (package-name package) (package-nicknames package))) + +(defun source-location (object) + (converting-errors-to-error-location + (typecase object + (c-function + (assert-source-directory) + (assert-TAGS-file) + (let ((lisp-name (function-name object))) + (assert lisp-name) + (multiple-value-bind (flag c-name) (si:mangle-name lisp-name t) + (assert flag) + ;; In ECL's code base sometimes the mangled name is used + ;; directly, sometimes ECL's DPP magic of @SI::SYMBOL or + ;; @EXT::SYMBOL is used. We cannot predict here, so we just + ;; provide several candidates. + (apply #'make-TAGS-location + c-name + (loop with s = (symbol-name lisp-name) + for p in (package-names (symbol-package lisp-name)) + collect (format nil "~A::~A" p s) + collect (format nil "~(~A::~A~)" p s)))))) + (function + (multiple-value-bind (file pos) (ext:compiled-function-file object) + (cond ((not file) + (return-from source-location nil)) + ((tmpfile-to-buffer file) + (make-buffer-location (tmpfile-to-buffer file) pos)) + (t + (assert (probe-file file)) + (assert (not (minusp pos))) + (make-file-location file pos))))) + (method + ;; FIXME: This will always return NIL at the moment; ECL does not + ;; store debug information for methods yet. + (source-location (clos:method-function object))) + ((member nil t) + (multiple-value-bind (flag c-name) (si:mangle-name object) + (assert flag) + (make-TAGS-location c-name)))))) + +(defimplementation find-source-location (object) + (or (source-location object) + (make-error-location "Source definition of ~S not found." object))) + +;;; buffer-first-change + + +;;;; XREF + +;;; who-calls +;;; calls-who +;;; who-references +;;; who-binds +;;; who-sets +;;; who-macroexpands +;;; who-specializes +;;; list-callers +;;; list-callees + + +;;;; Profiling + +;;; XXX: use monitor.lisp (ccl,clisp) + +#+profile +(progn + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) +) ; #+profile (progn ... + + +;;;; Trace + +;;; Toggle tracing of the function(s) given with SPEC. +;;; SPEC can be: +;;; (setf NAME) ; a setf function +;;; (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method +;;; (:defgeneric NAME) ; a generic function with all methods +;;; (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. +;;; (:labels TOPLEVEL LOCAL) +;;; (:flet TOPLEVEL LOCAL) +;;; +;;; toggle-trace (spec) + + +;;;; Inspector + +;;; FIXME: Would be nice if it was possible to inspect objects +;;; implemented in C. + +;;; Return a list of bindings corresponding to OBJECT's slots. +;;; eval-context (object) + +;;; Return a string describing the primitive type of object. +;;; describe-primitive-type (object) + + +;;;; Multithreading + +;;; Not needed in ECL +;;; +;;; initialize-multiprocessing + +#+threads +(progn + (defvar *thread-id-counter* 0) + + (defparameter *thread-id-map* (make-hash-table)) + + (defvar *thread-id-map-lock* + (mp:make-lock :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (mp:process-run-function name fn)) + + (defimplementation thread-id (target-thread) + (block thread-id + (mp:with-lock (*thread-id-map-lock*) + ;; Does TARGET-THREAD have an id already? + (maphash (lambda (id thread-pointer) + (let ((thread (si:weak-pointer-value thread-pointer))) + (cond ((not thread) + (remhash id *thread-id-map*)) + ((eq thread target-thread) + (return-from thread-id id))))) + *thread-id-map*) + ;; TARGET-THREAD not found in *THREAD-ID-MAP* + (let ((id (incf *thread-id-counter*)) + (thread-pointer (si:make-weak-pointer target-thread))) + (setf (gethash id *thread-id-map*) thread-pointer) + id)))) + + (defimplementation find-thread (id) + (mp:with-lock (*thread-id-map-lock*) + (let* ((thread-ptr (gethash id *thread-id-map*)) + (thread (and thread-ptr (si:weak-pointer-value thread-ptr)))) + (unless thread + (remhash id *thread-id-map*)) + thread))) + + (defimplementation thread-name (thread) + (mp:process-name thread)) + + (defimplementation thread-status (thread) + (if (mp:process-active-p thread) + "RUNNING" + "STOPPED")) + + ;; thread-attributes + + (defimplementation current-thread () + mp:*current-process*) + + (defimplementation all-threads () + (mp:all-processes)) + + (defimplementation thread-alive-p (thread) + (mp:process-active-p thread)) + + (defimplementation interrupt-thread (thread fn) + (mp:interrupt-process thread fn)) + + (defimplementation kill-thread (thread) + (mp:process-kill thread)) + + (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (mp:make-lock)) + (cvar (mp:make-condition-variable)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (mp:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (mp:with-lock (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (mp:condition-variable-broadcast (mailbox.cvar mbox))))) + + ;; receive + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (mp:with-lock (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (mp:condition-variable-wait (mailbox.cvar mbox) mutex))))) + + ;; Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using + ;; asynchronous interrupts. + ;; + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient. + ;; + ;; wake-thread (thread) + + ;; Copied from sbcl.lisp and adjusted to ECL. + (let ((alist '()) + (mutex (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (mutex) + (cdr (assoc name alist))))) + + ;; Not needed in ECL (?). + ;; + ;; set-default-initial-binding (var form) + + ) ; #+threads + +;;; Instead of busy waiting with communication-style NIL, use select() +;;; on the sockets' streams. +#+serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (flet ((poll-streams (streams timeout) + (let* ((serve-event::*descriptor-handlers* + (copy-list serve-event::*descriptor-handlers*)) + (active-fds '()) + (fd-stream-alist + (loop for s in streams + for fd = (socket-fd s) + collect (cons fd s) + do (serve-event:add-fd-handler fd :input + #'(lambda (fd) + (push fd active-fds)))))) + (serve-event:serve-event timeout) + (loop for fd in active-fds collect (cdr (assoc fd fd-stream-alist)))))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (poll-streams streams 0))) + (t + (when-let (ready (poll-streams streams 0.2)) + (return ready))))))) + +#-serve-event +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (loop + (cond ((check-slime-interrupts) (return :interrupt)) + (timeout (return (remove-if-not #'listen streams))) + (t + (let ((ready (remove-if-not #'listen streams))) + (if ready (return ready)) + (sleep 0.1)))))) + + +;;;; Locks + +#+threads +(defimplementation make-lock (&key name) + (mp:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mp:with-lock (lock) (funcall function))) + + +;;;; Weak datastructures + +;;; XXX: this should work but causes SLIME REPL hang at some point of time. May +;;; be ECL or SLIME bug - disabling for now. +#+(and ecl-weak-hash (or)) +(progn + (defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weakness :key args)) + + (defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weakness :value args)) + + (defimplementation hash-table-weakness (hashtable) + (ext:hash-table-weakness hashtable))) + + +;;;; Character names + +;;; Default implementation is fine. +;;; +;;; character-completion-set (prefix matchp) + + +;;;; Heap dumps + +;;; Doesn't apply to ECL. +;;; +;;; save-image (filename &optional restart-function) +;;; background-save-image (filename &key restart-function completion-function) + + +;;;; Wrapping + +;;; Intercept future calls to SPEC and surround them in callbacks. +;;; Very much similar to so-called advices for normal functions. +;;; +;;; wrap (spec indicator &key before after replace) +;;; unwrap (spec indicator) +;;; wrapped-p (spec indicator) blob - /dev/null blob + ed552ff26a46a8c41ad807239c2443e281322cd6 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/lispworks.lisp @@ -0,0 +1,1033 @@ +;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-lispworks.lisp --- LispWorks specific code for SLIME. +;;; +;;; Created 2003, Helmut Eller +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage slynk-lispworks + (:use cl slynk-backend)) + +(in-package slynk-lispworks) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defimplementation gray-package-name () + "STREAM") + +(import-slynk-mop-symbols :clos '(:slot-definition-documentation + :slot-boundp-using-class + :slot-value-using-class + :slot-makunbound-using-class + :eql-specializer + :eql-specializer-object + :compute-applicable-methods-using-classes)) + +(defun slynk-mop:slot-definition-documentation (slot) + (documentation slot t)) + +(defun slynk-mop:slot-boundp-using-class (class object slotd) + (clos:slot-boundp-using-class class object + (clos:slot-definition-name slotd))) + +(defun slynk-mop:slot-value-using-class (class object slotd) + (clos:slot-value-using-class class object + (clos:slot-definition-name slotd))) + +(defun (setf slynk-mop:slot-value-using-class) (value class object slotd) + (setf (clos:slot-value-using-class class object + (clos:slot-definition-name slotd)) + value)) + +(defun slynk-mop:slot-makunbound-using-class (class object slotd) + (clos:slot-makunbound-using-class class object + (clos:slot-definition-name slotd))) + +(defun slynk-mop:compute-applicable-methods-using-classes (gf classes) + (clos::compute-applicable-methods-from-classes gf classes)) + +;; lispworks doesn't have the eql-specializer class, it represents +;; them as a list of `(EQL ,OBJECT) +(deftype slynk-mop:eql-specializer () 'cons) + +(defun slynk-mop:eql-specializer-object (eql-spec) + (second eql-spec)) + +(eval-when (:compile-toplevel :execute :load-toplevel) + (defvar *original-defimplementation* (macro-function 'defimplementation)) + (defmacro defimplementation (&whole whole name args &body body + &environment env) + (declare (ignore args body)) + `(progn + (dspec:record-definition '(defun ,name) (dspec:location) + :check-redefinition-p nil) + ,(funcall *original-defimplementation* whole env)))) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (ef:encode-lisp-string string '(:utf-8 :eol-style :lf))) + +(defimplementation utf8-to-string (octets) + (ef:decode-external-string octets '(:utf-8 :eol-style :lf))) + +;;; TCP server + +(defimplementation preferred-communication-style () + :spawn) + +(defun socket-fd (socket) + (etypecase socket + (fixnum socket) + (comm:socket-stream (comm:socket-stream-socket socket)))) + +(defimplementation create-socket (host port &key backlog) + (multiple-value-bind (socket where errno) + #-(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port :address host + :backlog (or backlog 5)) + #+(or lispworks4.1 (and macosx lispworks4.3)) + (comm::create-tcp-socket-for-service port) + (cond (socket socket) + (t (error 'network-error + :format-control "~A failed: ~A (~D)" + :format-arguments (list where + (list #+unix (lw:get-unix-error errno)) + errno)))))) + +(defimplementation local-port (socket) + (nth-value 1 (comm:get-socket-address (socket-fd socket)))) + +(defimplementation close-socket (socket) + (comm::close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (declare (ignore buffering)) + (let* ((fd (comm::get-fd-from-socket socket))) + (assert (/= fd -1)) + (cond ((not external-format) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8))) + (t + (assert (valid-external-format-p external-format)) + (ecase (first external-format) + ((:latin-1 :ascii) + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type 'base-char)) + (:utf-8 + (make-flexi-stream + (make-instance 'comm:socket-stream + :socket fd + :direction :io + :read-timeout timeout + :element-type '(unsigned-byte 8)) + external-format))))))) + +(defun make-flexi-stream (stream external-format) + (unless (member :flexi-streams *features*) + (error "Cannot use external format ~A~ + without having installed flexi-streams in the inferior-lisp." + external-format)) + (funcall (slynk-backend:find-symbol2 "FLEXI-STREAMS:MAKE-FLEXI-STREAM") + stream + :external-format + (apply (slynk-backend:find-symbol2 + "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT") + external-format))) + +;;; Coding Systems + +(defun valid-external-format-p (external-format) + (member external-format *external-format-to-coding-system* + :test #'equal :key #'car)) + +(defvar *external-format-to-coding-system* + '(((:latin-1 :eol-style :lf) + "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix") + ;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1") + ;;((:utf-8) "utf-8") + ((:utf-8 :eol-style :lf) "utf-8-unix") + ;;((:euc-jp) "euc-jp") + ((:euc-jp :eol-style :lf) "euc-jp-unix") + ;;((:ascii) "us-ascii") + ((:ascii :eol-style :lf) "us-ascii-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +;;; Unix signals + +(defun sigint-handler () + (with-simple-restart (continue "Continue from SIGINT handler.") + (invoke-debugger "SIGINT"))) + +(defun make-sigint-handler (process) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt process #'sigint-handler))) + +(defun set-sigint-handler () + ;; Set SIGINT handler on Slynk request handler thread. + #-win32 + (sys::set-signal-handler sys::unix-sigint + (make-sigint-handler mp:*current-process*))) + +#-win32 +(defimplementation install-sigint-handler (handler) + (sys::set-signal-handler sys::unix-sigint + (let ((self mp:*current-process*)) + (lambda (&rest args) + (declare (ignore args)) + (mp:process-interrupt self handler))))) + +(defimplementation getpid () + #+win32 (win32:get-current-process-id) + #-win32 (system::getpid)) + +(defimplementation lisp-implementation-type-name () + "lispworks") + +(defimplementation set-default-directory (directory) + (namestring (hcl:change-directory directory))) + +;;;; Documentation + +(defun map-list (function list) + "Map over proper and not proper lists." + (loop for (car . cdr) on list + collect (funcall function car) into result + when (null cdr) return result + when (atom cdr) return (nconc result (funcall function cdr)))) + +(defun replace-strings-with-symbols (tree) + (map-list + (lambda (x) + (typecase x + (list + (replace-strings-with-symbols x)) + (symbol + x) + (string + (intern x)) + (t + (intern (write-to-string x))))) + tree)) + +(defimplementation arglist (symbol-or-function) + (let ((arglist (lw:function-lambda-list symbol-or-function))) + (etypecase arglist + ((member :dont-know) + :not-available) + (list + (replace-strings-with-symbols arglist))))) + +(defimplementation function-name (function) + (nth-value 2 (function-lambda-expression function))) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:walk-form form)) + +(defun generic-function-p (object) + (typep object 'generic-function)) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (labels ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos)))) + (doc (kind &optional (sym symbol)) + (let ((string (or (documentation sym kind)))) + (if string + (first-line string) + :not-documented))) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (when (boundp symbol) + (doc 'variable))) + (maybe-push + :generic-function (if (and (fboundp symbol) + (generic-function-p (fdefinition symbol))) + (doc 'function))) + (maybe-push + :function (if (and (fboundp symbol) + (not (generic-function-p (fdefinition symbol)))) + (doc 'function))) + (maybe-push + :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol)))) + (if (fboundp setf-name) + (doc 'setf)))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + result))) + +(defimplementation describe-definition (symbol type) + (ecase type + (:variable (describe-symbol symbol)) + (:class (describe (find-class symbol))) + ((:function :generic-function) (describe-function symbol)) + (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol)))))) + +(defun describe-function (symbol) + (cond ((fboundp symbol) + (format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%" + symbol + (lispworks:function-lambda-list symbol) + (documentation symbol 'function)) + (describe (fdefinition symbol))) + (t (format t "~S is not fbound" symbol)))) + +(defun describe-symbol (sym) + (format t "~A is a symbol in package ~A." sym (symbol-package sym)) + (when (boundp sym) + (format t "~%~%Value: ~A" (symbol-value sym))) + (let ((doc (documentation sym 'variable))) + (when doc + (format t "~%~%Variable documentation:~%~A" doc))) + (when (fboundp sym) + (describe-function sym))) + +(defimplementation type-specifier-p (symbol) + (or (ignore-errors + (subtypep nil symbol)) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +;;; Debugging + +(defclass sly-env (env:environment) + ((debugger-hook :initarg :debugger-hoook))) + +(defun sly-env (hook io-bindings) + (make-instance 'sly-env :name "SLY Environment" + :io-bindings io-bindings + :debugger-hoook hook)) + +(defmethod env-internals:environment-display-notifier + ((env sly-env) &key restarts condition) + (declare (ignore restarts condition)) + (funcall (slynk-sym :slynk-debugger-hook) condition *debugger-hook*) + ;; nil + ) + +(defmethod env-internals:environment-display-debugger ((env sly-env)) + *debug-io*) + +(defmethod env-internals:confirm-p ((e sly-env) &optional msg &rest args) + (apply (slynk-sym :y-or-n-p-in-emacs) msg args)) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook)) + (env:with-environment ((sly-env hook '())) + (funcall fun)))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (setf (env:environment) (sly-env function '()))) + +(defvar *sly-db-top-frame*) + +(defun interesting-frame-p (frame) + (cond ((or (dbg::call-frame-p frame) + (dbg::derived-call-frame-p frame) + (dbg::foreign-frame-p frame) + (dbg::interpreted-call-frame-p frame)) + t) + ((dbg::catch-frame-p frame) dbg:*print-catch-frames*) + ((dbg::binding-frame-p frame) dbg:*print-binding-frames*) + ((dbg::handler-frame-p frame) dbg:*print-handler-frames*) + ((dbg::restart-frame-p frame) dbg:*print-restart-frames*) + (t nil))) + +(defun nth-next-frame (frame n) + "Unwind FRAME N times." + (do ((frame frame (dbg::frame-next frame)) + (i n (if (interesting-frame-p frame) (1- i) i))) + ((or (not frame) + (and (interesting-frame-p frame) (zerop i))) + frame))) + +(defun nth-frame (index) + (nth-next-frame *sly-db-top-frame* index)) + +(defun find-top-frame () + "Return the most suitable top-frame for the debugger." + (flet ((find-named-frame (name) + (do ((frame (dbg::debugger-stack-current-frame + dbg::*debugger-stack*) + (nth-next-frame frame 1))) + ((or (null frame) ; no frame found! + (and (dbg::call-frame-p frame) + (eq (dbg::call-frame-function-name frame) + name))) + (nth-next-frame frame 1))))) + (or (find-named-frame 'invoke-debugger) + (find-named-frame (slynk-sym :safe-backtrace)) + ;; if we can't find a likely top frame, take any old frame + ;; at the top + (dbg::debugger-stack-current-frame dbg::*debugger-stack*)))) + +(defimplementation call-with-debugging-environment (fn) + (dbg::with-debugger-stack () + (let ((*sly-db-top-frame* (find-top-frame))) + (funcall fn)))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum)) + (backtrace '())) + (do ((frame (nth-frame start) (dbg::frame-next frame)) + (i start)) + ((or (not frame) (= i end)) (nreverse backtrace)) + (when (interesting-frame-p frame) + (incf i) + (push frame backtrace))))) + +(defun frame-actual-args (frame) + (let ((*break-on-signals* nil) + (kind nil)) + (loop for arg in (dbg::call-frame-arglist frame) + if (eq kind '&rest) + nconc (handler-case + (dbg::dbg-eval arg frame) + (error (e) (list (format nil "<~A>" arg)))) + and do (loop-finish) + else + if (member arg '(&rest &optional &key)) + do (setq kind arg) + else + nconc + (handler-case + (nconc (and (eq kind '&key) + (list (cond ((symbolp arg) + (intern (symbol-name arg) :keyword)) + ((and (consp arg) (symbolp (car arg))) + (intern (symbol-name (car arg)) + :keyword)) + (t (caar arg))))) + (list (dbg::dbg-eval + (cond ((symbolp arg) arg) + ((and (consp arg) (symbolp (car arg))) + (car arg)) + (t (cadar arg))) + frame))) + (error (e) (list (format nil "<~A>" arg))))))) + +(defimplementation print-frame (frame stream) + (cond ((dbg::call-frame-p frame) + (prin1 (cons (dbg::call-frame-function-name frame) + (frame-actual-args frame)) + stream)) + (t (princ frame stream)))) + +(defun frame-vars (frame) + (first (dbg::frame-locals-format-list frame #'list 75 0))) + +(defimplementation frame-locals (n) + (let ((frame (nth-frame n))) + (if (dbg::call-frame-p frame) + (mapcar (lambda (var) + (destructuring-bind (name value symbol location) var + (declare (ignore name location)) + (list :name symbol :id 0 + :value value))) + (frame-vars frame))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (destructuring-bind (_n value _s _l) (nth var (frame-vars frame)) + (declare (ignore _n _s _l)) + value))) + +(defimplementation frame-source-location (frame) + (let ((frame (nth-frame frame)) + (callee (if (plusp frame) (nth-frame (1- frame))))) + (if (dbg::call-frame-p frame) + (let ((dspec (dbg::call-frame-function-name frame)) + (cname (and (dbg::call-frame-p callee) + (dbg::call-frame-function-name callee))) + (path (and (dbg::call-frame-p frame) + (dbg::call-frame-edit-path frame)))) + (if dspec + (frame-location dspec cname path)))))) + +(defimplementation eval-in-frame (form frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::dbg-eval form frame))) + +(defun function-name-package (name) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql hcl:subfunction)) + (destructuring-bind (name parent) (cdr name) + (declare (ignore name)) + (function-name-package parent))) + ((cons (eql lw:top-level-form)) nil) + (t nil))) + +(defimplementation frame-package (frame-number) + (let ((frame (nth-frame frame-number))) + (if (dbg::call-frame-p frame) + (function-name-package (dbg::call-frame-function-name frame))))) + +(defimplementation return-from-frame (frame-number form) + (let* ((frame (nth-frame frame-number)) + (return-frame (dbg::find-frame-for-return frame))) + (dbg::dbg-return-from-call-frame frame form return-frame + dbg::*debugger-stack*))) + +(defimplementation restart-frame (frame-number) + (let ((frame (nth-frame frame-number))) + (dbg::restart-frame frame :same-args t))) + +(defimplementation disassemble-frame (frame-number) + (let* ((frame (nth-frame frame-number))) + (when (dbg::call-frame-p frame) + (let ((function (dbg::get-call-frame-function frame))) + (disassemble function))))) + +;;; Definition finding + +(defun frame-location (dspec callee-name edit-path) + (let ((infos (dspec:find-dspec-locations dspec))) + (cond (infos + (destructuring-bind ((rdspec location) &rest _) infos + (declare (ignore _)) + (let ((name (and callee-name (symbolp callee-name) + (string callee-name))) + (path (edit-path-to-cmucl-source-path edit-path))) + (make-dspec-location rdspec location + `(:call-site ,name :edit-path ,path))))) + (t + (list :error (format nil "Source location not available for: ~S" + dspec)))))) + +;; dbg::call-frame-edit-path is not documented but lets assume the +;; binary representation of the integer EDIT-PATH should be +;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the +;; same as cadadddr. Something is odd with the highest bit. +(defun edit-path-to-cmucl-source-path (edit-path) + (and edit-path + (cons 0 + (let ((n -1)) + (loop for i from (1- (integer-length edit-path)) downto 0 + if (logbitp i edit-path) do (incf n) + else collect (prog1 n (setq n 0))))))) + +;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1) + +(defimplementation find-definitions (name) + (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name))) + (loop for (dspec location) in locations + collect (list dspec (make-dspec-location dspec location))))) + + +;;; Compilation + +(defmacro with-slynk-compilation-unit ((location &rest options) &body body) + (lw:rebinding (location) + `(let ((compiler::*error-database* '())) + (with-compilation-unit ,options + (multiple-value-prog1 (progn ,@body) + (signal-error-data-base compiler::*error-database* + ,location) + (signal-undefined-functions compiler::*unknown-functions* + ,location)))))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-slynk-compilation-unit (input-file) + (compile-file input-file + :output-file output-file + :load load-p + :external-format external-format))) + +(defvar *within-call-with-compilation-hooks* nil + "Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.") + +(defvar *undefined-functions-hash* nil + "Hash table to map info about undefined functions to pathnames.") + +(lw:defadvice (compile-file compile-file-and-collect-notes :around) + (pathname &rest rest) + (multiple-value-prog1 (apply #'lw:call-next-advice pathname rest) + (when *within-call-with-compilation-hooks* + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (let ((unfun-info (list unfun dspec))) + (unless (gethash unfun-info *undefined-functions-hash*) + (setf (gethash unfun-info *undefined-functions-hash*) + pathname))))) + compiler::*unknown-functions*)))) + +(defimplementation call-with-compilation-hooks (function) + (let ((compiler::*error-database* '()) + (*undefined-functions-hash* (make-hash-table :test 'equal)) + (*within-call-with-compilation-hooks* t)) + (with-compilation-unit () + (prog1 (funcall function) + (signal-error-data-base compiler::*error-database*) + (signal-undefined-functions compiler::*unknown-functions*))))) + +(defun map-error-database (database fn) + (loop for (filename . defs) in database do + (loop for (dspec . conditions) in defs do + (dolist (c conditions) + (multiple-value-bind (condition path) + (if (consp c) (values (car c) (cdr c)) (values c nil)) + (funcall fn filename dspec condition path)))))) + +(defun lispworks-severity (condition) + (cond ((not condition) :warning) + (t (etypecase condition + #-(or lispworks4 lispworks5) + (conditions:compiler-note :note) + (error :error) + (style-warning :warning) + (warning :warning))))) + +(defun signal-compiler-condition (message location condition) + (check-type message string) + (signal + (make-instance 'compiler-condition :message message + :severity (lispworks-severity condition) + :location location + :original-condition condition))) + +(defvar *temp-file-format* '(:utf-8 :eol-style :lf)) + +(defun compile-from-temp-file (string filename) + (unwind-protect + (progn + (with-open-file (s filename :direction :output + :if-exists :supersede + :external-format *temp-file-format*) + + (write-string string s) + (finish-output s)) + (multiple-value-bind (binary-filename warnings? failure?) + (compile-file filename :load t + :external-format *temp-file-format*) + (declare (ignore warnings?)) + (when binary-filename + (delete-file binary-filename)) + (not failure?))) + (delete-file filename))) + +(defun dspec-function-name-position (dspec fallback) + (etypecase dspec + (cons (let ((name (dspec:dspec-primary-name dspec))) + (typecase name + ((or symbol string) + (list :function-name (string name))) + (t fallback)))) + (null fallback) + (symbol (list :function-name (string dspec))))) + +(defmacro with-fairly-standard-io-syntax (&body body) + "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*." + (let ((package (gensym)) + (readtable (gensym))) + `(let ((,package *package*) + (,readtable *readtable*)) + (with-standard-io-syntax + (let ((*package* ,package) + (*readtable* ,readtable)) + ,@body))))) + +(defun skip-comments (stream) + (let ((pos0 (file-position stream))) + (cond ((equal (ignore-errors (list (read-delimited-list #\( stream))) + '(())) + (file-position stream (1- (file-position stream)))) + (t (file-position stream pos0))))) + +#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3 +(defun dspec-stream-position (stream dspec) + (with-fairly-standard-io-syntax + (loop (let* ((pos (progn (skip-comments stream) (file-position stream))) + (form (read stream nil '#1=#:eof))) + (when (eq form '#1#) + (return nil)) + (labels ((check-dspec (form) + (when (consp form) + (let ((operator (car form))) + (case operator + ((progn) + (mapcar #'check-dspec + (cdr form))) + ((eval-when locally macrolet symbol-macrolet) + (mapcar #'check-dspec + (cddr form))) + ((in-package) + (let ((package (find-package (second form)))) + (when package + (setq *package* package)))) + (otherwise + (let ((form-dspec (dspec:parse-form-dspec form))) + (when (dspec:dspec-equal dspec form-dspec) + (return pos))))))))) + (check-dspec form)))))) + +(defun dspec-file-position (file dspec) + (let* ((*compile-file-pathname* (pathname file)) + (*compile-file-truename* (truename *compile-file-pathname*)) + (*load-pathname* *compile-file-pathname*) + (*load-truename* *compile-file-truename*)) + (with-open-file (stream file) + (let ((pos + #-(or lispworks4.1 lispworks4.2) + (ignore-errors (dspec-stream-position stream dspec)))) + (if pos + (list :position (1+ pos)) + (dspec-function-name-position dspec `(:position 1))))))) + +(defun emacs-buffer-location-p (location) + (and (consp location) + (eq (car location) :emacs-buffer))) + +(defun make-dspec-location (dspec location &optional hints) + (etypecase location + ((or pathname string) + (multiple-value-bind (file err) + (ignore-errors (namestring (truename location))) + (if err + (list :error (princ-to-string err)) + (make-location `(:file ,file) + (dspec-file-position file dspec) + hints)))) + (symbol + `(:error ,(format nil "Cannot resolve location: ~S" location))) + ((satisfies emacs-buffer-location-p) + (destructuring-bind (_ buffer offset) location + (declare (ignore _)) + (make-location `(:buffer ,buffer) + (dspec-function-name-position dspec `(:offset ,offset 0)) + hints))))) + +(defun make-dspec-progenitor-location (dspec location edit-path) + (let ((canon-dspec (dspec:canonicalize-dspec dspec))) + (make-dspec-location + (if canon-dspec + (if (dspec:local-dspec-p canon-dspec) + (dspec:dspec-progenitor canon-dspec) + canon-dspec) + nil) + location + (if edit-path + (list :edit-path (edit-path-to-cmucl-source-path edit-path)))))) + +(defun signal-error-data-base (database &optional location) + (map-error-database + database + (lambda (filename dspec condition edit-path) + (signal-compiler-condition + (format nil "~A" condition) + (make-dspec-progenitor-location dspec (or location filename) edit-path) + condition)))) + +(defun unmangle-unfun (symbol) + "Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to +function names like \(SETF GET)." + (cond ((sys::setf-symbol-p symbol) + (sys::setf-pair-from-underlying-name symbol)) + (t symbol))) + +(defun signal-undefined-functions (htab &optional filename) + (maphash (lambda (unfun dspecs) + (dolist (dspec dspecs) + (signal-compiler-condition + (format nil "Undefined function ~A" (unmangle-unfun unfun)) + (make-dspec-progenitor-location + dspec + (or filename + (gethash (list unfun dspec) *undefined-functions-hash*)) + nil) + nil))) + htab)) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (assert buffer) + (assert position) + (let* ((location (list :emacs-buffer buffer position)) + (tmpname (hcl:make-temp-file nil "lisp"))) + (with-slynk-compilation-unit (location) + (compile-from-temp-file + (with-output-to-string (s) + (let ((*print-radix* t)) + (print `(eval-when (:compile-toplevel) + (setq dspec::*location* (list ,@location))) + s)) + (write-string string s)) + tmpname)))) + +;;; xref + +(defmacro defxref (name function) + `(defimplementation ,name (name) + (xref-results (,function name)))) + +(defxref who-calls hcl:who-calls) +(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too +(defxref calls-who hcl:calls-who) +(defxref list-callers list-callers-internal) +(defxref list-callees list-callees-internal) + +(defun list-callers-internal (name) + (let ((callers (make-array 100 + :fill-pointer 0 + :adjustable t))) + (hcl:sweep-all-objects + #'(lambda (object) + (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object) + #+Harlequin-Unix-Lisp (sys:callablep object) + #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) + (sys:compiled-code-p object) + (system::find-constant$funcallable name object)) + (vector-push-extend object callers)))) + ;; Delay dspec:object-dspec until after sweep-all-objects + ;; to reduce allocation problems. + (loop for object across callers + collect (if (symbolp object) + (list 'function object) + (or (dspec:object-dspec object) object))))) + +(defun list-callees-internal (name) + (let ((callees '())) + (system::find-constant$funcallable + 'junk name + :test #'(lambda (junk constant) + (declare (ignore junk)) + (when (and (symbolp constant) + (fboundp constant)) + (pushnew (list 'function constant) callees :test 'equal)) + ;; Return nil so we iterate over all constants. + nil)) + callees)) + +;; only for lispworks 4.2 and above +#-lispworks4.1 +(progn + (defxref who-references hcl:who-references) + (defxref who-binds hcl:who-binds) + (defxref who-sets hcl:who-sets)) + +(defimplementation who-specializes (classname) + (let ((class (find-class classname nil))) + (when class + (let ((methods (clos:class-direct-methods class))) + (xref-results (mapcar #'dspec:object-dspec methods)))))) + +(defun xref-results (dspecs) + (flet ((frob-locs (dspec locs) + (cond (locs + (loop for (name loc) in locs + collect (list name (make-dspec-location name loc)))) + (t `((,dspec (:error "Source location not available"))))))) + (loop for dspec in dspecs + append (frob-locs dspec (dspec:dspec-definition-locations dspec))))) + +;;; Inspector + +(defmethod emacs-inspect ((o t)) + (lispworks-inspect o)) + +(defmethod emacs-inspect ((o function)) + (lispworks-inspect o)) + +;; FIXME: slot-boundp-using-class in LW works with names so we can't +;; use our method in slynk.lisp. +(defmethod emacs-inspect ((o standard-object)) + (lispworks-inspect o)) + +(defun lispworks-inspect (o) + (multiple-value-bind (names values _getter _setter type) + (lw:get-inspector-values o nil) + (declare (ignore _getter _setter)) + (append + (label-value-line "Type" type) + (loop for name in names + for value in values + append (label-value-line name value))))) + +;;; Miscellaneous + +(defimplementation quit-lisp () + (lispworks:quit)) + +;;; Tracing + +(defun parse-fspec (fspec) + "Return a dspec for FSPEC." + (ecase (car fspec) + ((:defmethod) `(method ,(cdr fspec))))) + +(defun tracedp (dspec) + (member dspec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (dspec) + (cond ((tracedp dspec) + (eval `(untrace ,dspec)) + (format nil "~S is now untraced." dspec)) + (t + (eval `(trace (,dspec))) + (format nil "~S is now traced." dspec)))) + +(defimplementation toggle-trace (fspec) + (toggle-trace-aux (parse-fspec fspec))) + +;;; Multithreading + +(defimplementation initialize-multiprocessing (continuation) + (cond ((not mp::*multiprocessing*) + (push (list "Initialize SLY" '() continuation) + mp:*initial-processes*) + (mp:initialize-multiprocessing)) + (t (funcall continuation)))) + +(defimplementation spawn (fn &key name) + (mp:process-run-function name () fn)) + +(defvar *id-lock* (mp:make-lock)) +(defvar *thread-id-counter* 0) + +(defimplementation thread-id (thread) + (mp:with-lock (*id-lock*) + (or (getf (mp:process-plist thread) 'id) + (setf (getf (mp:process-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (find id (mp:list-all-processes) + :key (lambda (p) (getf (mp:process-plist p) 'id)))) + +(defimplementation thread-name (thread) + (mp:process-name thread)) + +(defimplementation thread-status (thread) + (format nil "~A ~D" + (mp:process-whostate thread) + (mp:process-priority thread))) + +(defimplementation make-lock (&key name) + (mp:make-lock :name name)) + +(defimplementation call-with-lock-held (lock function) + (mp:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mp:*current-process*) + +(defimplementation all-threads () + (mp:list-all-processes)) + +(defimplementation interrupt-thread (thread fn) + (mp:process-interrupt thread fn)) + +(defimplementation kill-thread (thread) + (mp:process-kill thread)) + +(defimplementation thread-alive-p (thread) + (mp:process-alive-p thread)) + +(defstruct (mailbox (:conc-name mailbox.)) + (mutex (mp:make-lock :name "thread mailbox")) + (queue '() :type list)) + +(defvar *mailbox-lock* (mp:make-lock)) + +(defun mailbox (thread) + (mp:with-lock (*mailbox-lock*) + (or (getf (mp:process-plist thread) 'mailbox) + (setf (getf (mp:process-plist thread) 'mailbox) + (make-mailbox))))) + +(defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox mp:*current-process*)) + (lock (mailbox.mutex mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (mp:with-lock (lock "receive-if/try") + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox))))))) + +(defimplementation send (thread message) + (let ((mbox (mailbox thread))) + (mp:with-lock ((mailbox.mutex mbox)) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message)))))) + +(let ((alist '()) + (lock (mp:make-lock :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (mp:with-lock (lock) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (mp:process + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (mp:with-lock (lock) + (cdr (assoc name alist))))) + + +(defimplementation set-default-initial-binding (var form) + (setq mp:*process-initial-bindings* + (acons var `(eval (quote ,form)) + mp:*process-initial-bindings* ))) + +(defimplementation thread-attributes (thread) + (list :priority (mp:process-priority thread) + :idle (mp:process-idle-time thread))) + +;;; Some intergration with the lispworks environment + +(defun slynk-sym (name) (find-symbol (string name) :slynk)) + + +;;;; Weak hashtables + +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :key args)) + +(defimplementation make-weak-value-hash-table (&rest args) + (apply #'make-hash-table :weak-kind :value args)) + +;;;; Packages + +#+#.(slynk-backend:with-symbol 'package-local-nicknames 'hcl) +(defimplementation package-local-nicknames (package) + (hcl:package-local-nicknames package)) blob - /dev/null blob + d0751a70f89e83f90aa856ae20fe9c39160acf67 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/mkcl.lisp @@ -0,0 +1,935 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-mkcl.lisp --- SLIME backend for MKCL. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;;; Administrivia + +(defpackage slynk-mkcl + (:use cl slynk-backend)) + +(in-package slynk-mkcl) + +;;(declaim (optimize (debug 3))) + +(defvar *tmp*) + +(defimplementation gray-package-name () + '#:gray) + +(eval-when (:compile-toplevel :load-toplevel) + + (slynk-backend::import-slynk-mop-symbols :clos + ;; '(:eql-specializer + ;; :eql-specializer-object + ;; :generic-function-declarations + ;; :specializer-direct-methods + ;; :compute-applicable-methods-using-classes) + nil + )) + + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (mkcl:octets (si:utf-8 string))) + +(defimplementation utf8-to-string (octets) + (string (si:utf-8 octets))) + + +;;;; TCP Server + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the sb-bsd-sockets package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'sockets)) + + +(defun resolve-hostname (name) + (car (sb-bsd-sockets:host-ent-addresses + (sb-bsd-sockets:get-host-by-name name)))) + +(defimplementation create-socket (host port &key backlog) + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port) + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-bsd-sockets:socket-close socket)) + +(defun accept (socket) + "Like socket-accept, but retry on EINTR." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + +(defimplementation accept-connection (socket + &key external-format + buffering timeout) + (declare (ignore timeout)) + (sb-bsd-sockets:socket-make-stream (accept socket) + :output t ;; bogus + :input t ;; bogus + :buffering buffering ;; bogus + :element-type (if external-format + 'character + '(unsigned-byte 8)) + :external-format external-format + )) + +(defimplementation preferred-communication-style () + :spawn + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix"))) + +(defun external-format (coding-system) + (or (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*)) + (find coding-system (si:all-encodings) :test #'string-equal))) + +(defimplementation find-external-format (coding-system) + #+unicode (external-format coding-system) + ;; Without unicode support, MKCL uses the one-byte encoding of the + ;; underlying OS, and will barf on anything except :DEFAULT. We + ;; return NIL here for known multibyte encodings, so + ;; SLYNK:CREATE-SERVER will barf. + #-unicode (let ((xf (external-format coding-system))) + (if (member xf '(:utf-8)) + nil + :default))) + + + +;;;; Unix signals + +(defimplementation install-sigint-handler (handler) + (let ((old-handler (symbol-function 'si:terminal-interrupt))) + (setf (symbol-function 'si:terminal-interrupt) + (if (consp handler) + (car handler) + (lambda (&rest args) + (declare (ignore args)) + (funcall handler) + (continue)))) + (list old-handler))) + + +(defimplementation getpid () + (mkcl:getpid)) + +(defimplementation set-default-directory (directory) + (mk-ext::chdir (namestring directory)) + (default-directory)) + +(defimplementation default-directory () + (namestring (mk-ext:getcwd))) + +(defmacro progf (plist &rest forms) + `(let (_vars _vals) + (do ((p ,plist (cddr p))) + ((endp p)) + (push (car p) _vars) + (push (cadr p) _vals)) + (progv _vars _vals ,@forms) + ) + ) + +(defvar *inferior-lisp-sleeping-post* nil) + +(defimplementation quit-lisp () + ;; restore original IO streams. + (progf (ignore-errors (eval + (slynk-backend:find-symbol2 "slynk::*saved-global-streams*"))) + (when *inferior-lisp-sleeping-post* (mt:semaphore-signal *inferior-lisp-sleeping-post*)) + ;;(mk-ext:quit :verbose t) + )) + + +;;;; Compilation + +(defvar *buffer-name* nil) +(defvar *buffer-start-position*) +(defvar *buffer-string*) +(defvar *compile-filename*) + +(defun signal-compiler-condition (&rest args) + (signal (apply #'make-condition 'compiler-condition args))) + +#| +(defun handle-compiler-warning (condition) + (signal-compiler-condition + :original-condition condition + :message (format nil "~A" condition) + :severity :warning + :location + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* + ;; (if compiler::*current-function* + ;; (make-location (list :file *compile-filename*) + ;; (list :function-name + ;; (symbol-name + ;; (slot-value compiler::*current-function* + ;; 'compiler::name)))) + (list :error "No location found.") + ;; ) + ))) +|# + +#| +(defun condition-location (condition) + (let ((file (compiler:compiler-message-file condition)) + (position (compiler:compiler-message-file-position condition))) + (if (and position (not (minusp position))) + (if *buffer-name* + (make-buffer-location *buffer-name* + *buffer-start-position* + position) + (make-file-location file position)) + (make-error-location "No location found.")))) +|# + +(defun condition-location (condition) + (if *buffer-name* + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* 0)) + ;; ;; compiler::*current-form* ; + ;; (if compiler::*current-function* ; + ;; (make-location (list :file *compile-filename*) ; + ;; (list :function-name ; + ;; (symbol-name ; + ;; (slot-value compiler::*current-function* ; + ;; 'compiler::name)))) ; + (if (typep condition 'compiler::compiler-message) + (make-location (list :file (namestring (compiler:compiler-message-file condition))) + (list :end-position (compiler:compiler-message-file-end-position condition))) + (list :error "No location found.")) + ) + ) + +(defun handle-compiler-message (condition) + (unless (typep condition 'compiler::compiler-note) + (signal-compiler-condition + :original-condition condition + :message (princ-to-string condition) + :severity (etypecase condition + (compiler:compiler-fatal-error :error) + (compiler:compiler-error :error) + (error :error) + (style-warning :style-warning) + (warning :warning)) + :location (condition-location condition)))) + +(defimplementation call-with-compilation-hooks (function) + (handler-bind ((compiler:compiler-message #'handle-compiler-message)) + (funcall function))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (*compile-filename* input-file)) + (handler-bind (#| + (compiler::compiler-note + #'(lambda (n) + (format t "~%slynk saw a compiler note: ~A~%" n) (finish-output) nil)) + (compiler::compiler-warning + #'(lambda (w) + (format t "~%slynk saw a compiler warning: ~A~%" w) (finish-output) nil)) + (compiler::compiler-error + #'(lambda (e) + (format t "~%slynk saw a compiler error: ~A~%" e) (finish-output) nil)) + |# + ) + (multiple-value-bind (output-truename warnings-p failure-p) + (compile-file input-file :output-file output-file :external-format external-format) + (values output-truename warnings-p + (or failure-p + (and load-p (not (load output-truename)))))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-string* string)) + (with-input-from-string (s string) + (when position (file-position position)) + (compile-from-stream s))))) + +(defun compile-from-stream (stream) + (let ((file (mkcl:mkstemp "TMP:MKCL-SLYNK-TMPXXXXXX")) + output-truename + warnings-p + failure-p + ) + (with-open-file (s file :direction :output :if-exists :overwrite) + (do ((line (read-line stream nil) (read-line stream nil))) + ((not line)) + (write-line line s))) + (unwind-protect + (progn + (multiple-value-setq (output-truename warnings-p failure-p) + (compile-file file)) + (and (not failure-p) (load output-truename))) + (when (probe-file file) (delete-file file)) + (when (probe-file output-truename) (delete-file output-truename))))) + + +;;;; Documentation + +(defun grovel-docstring-for-arglist (name type) + (flet ((compute-arglist-offset (docstring) + (when docstring + (let ((pos1 (search "Args: " docstring))) + (if pos1 + (+ pos1 6) + (let ((pos2 (search "Syntax: " docstring))) + (when pos2 + (+ pos2 8)))))))) + (let* ((docstring (si::get-documentation name type)) + (pos (compute-arglist-offset docstring))) + (if pos + (multiple-value-bind (arglist errorp) + (ignore-errors + (values (read-from-string docstring t nil :start pos))) + (if (or errorp (not (listp arglist))) + :not-available + arglist + )) + :not-available )))) + +(defimplementation arglist (name) + (cond ((and (symbolp name) (special-operator-p name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((and (symbolp name) (macro-function name)) + (let ((arglist (grovel-docstring-for-arglist name 'function))) + (if (consp arglist) (cdr arglist) arglist))) + ((or (functionp name) (fboundp name)) + (multiple-value-bind (name fndef) + (if (functionp name) + (values (function-name name) name) + (values name (fdefinition name))) + (let ((fle (function-lambda-expression fndef))) + (case (car fle) + (si:lambda-block (caddr fle)) + (t (typecase fndef + (generic-function (clos::generic-function-lambda-list fndef)) + (compiled-function (grovel-docstring-for-arglist name 'function)) + (function :not-available))))))) + (t :not-available))) + +(defimplementation function-name (f) + (si:compiled-function-name f) + ) + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the walker package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'walker)) + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (walker:macroexpand-all form)) + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (dolist (type '(:VARIABLE :FUNCTION :CLASS)) + (let ((doc (describe-definition symbol type))) + (when doc + (setf result (list* type doc result))))) + result)) + +(defimplementation describe-definition (name type) + (case type + (:variable (documentation name 'variable)) + (:function (documentation name 'function)) + (:class (documentation name 'class)) + (t nil))) + +;;; Debugging + +(eval-when (:compile-toplevel :load-toplevel) + (import + '(si::*break-env* + si::*ihs-top* + si::*ihs-current* + si::*ihs-base* + si::*frs-base* + si::*frs-top* + si::*tpl-commands* + si::*tpl-level* + si::frs-top + si::ihs-top + si::ihs-fun + si::ihs-env + si::sch-frs-base + si::set-break-env + si::set-current-ihs + si::tpl-commands))) + +(defvar *backtrace* '()) + +(defun in-slynk-package-p (x) + (and + (symbolp x) + (member (symbol-package x) + (list #.(find-package :slynk) + #.(find-package :slynk-backend) + #.(ignore-errors (find-package :slynk-mop)) + #.(ignore-errors (find-package :slynk-loader)))) + t)) + +(defun is-slynk-source-p (name) + (setf name (pathname name)) + #+(or) + (pathname-match-p + name + (make-pathname :defaults slynk-loader::*source-directory* + :name (pathname-name name) + :type (pathname-type name) + :version (pathname-version name))) + nil) + +(defun is-ignorable-fun-p (x) + (or + (in-slynk-package-p (frame-name x)) + (multiple-value-bind (file position) + (ignore-errors (si::compiled-function-file (car x))) + (declare (ignore position)) + (if file (is-slynk-source-p file))))) + +(defmacro find-ihs-top (x) + (declare (ignore x)) + '(si::ihs-top)) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let* (;;(*tpl-commands* si::tpl-commands) + (*ihs-base* 0) + (*ihs-top* (find-ihs-top 'call-with-debugging-environment)) + (*ihs-current* *ihs-top*) + (*frs-base* (or (sch-frs-base 0 #|*frs-top*|# *ihs-base*) (1+ (frs-top)))) + (*frs-top* (frs-top)) + (*read-suppress* nil) + ;;(*tpl-level* (1+ *tpl-level*)) + (*backtrace* (loop for ihs from 0 below *ihs-top* + collect (list (si::ihs-fun ihs) + (si::ihs-env ihs) + nil)))) + (declare (special *ihs-current*)) + (loop for f from *frs-base* to *frs-top* + do (let ((i (- (si::frs-ihs f) *ihs-base* 1))) + (when (plusp i) + (let* ((x (elt *backtrace* i)) + (name (si::frs-tag f))) + (unless (mkcl:fixnump name) + (push name (third x))))))) + (setf *backtrace* (remove-if #'is-ignorable-fun-p (nreverse *backtrace*))) + (setf *tmp* *backtrace*) + (set-break-env) + (set-current-ihs) + (let ((*ihs-base* *ihs-top*)) + (funcall debugger-loop-fn)))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + (*ihs-base* (find-ihs-top 'call-with-debugger-hook))) + (funcall fun))) + +(defimplementation compute-backtrace (start end) + (when (numberp end) + (setf end (min end (length *backtrace*)))) + (loop for f in (subseq *backtrace* start end) + collect f)) + +(defimplementation format-sldb-condition (condition) + "Format a condition for display in SLDB." + ;;(princ-to-string condition) + (format nil "~A~%In thread: ~S" condition mt:*thread*) + ) + +(defun frame-name (frame) + (let ((x (first frame))) + (if (symbolp x) + x + (function-name x)))) + +(defun function-position (fun) + (multiple-value-bind (file position) + (si::compiled-function-file fun) + (and file (make-location + `(:file ,(if (stringp file) file (namestring file))) + ;;`(:position ,position) + `(:end-position , position))))) + +(defun frame-function (frame) + (let* ((x (first frame)) + fun position) + (etypecase x + (symbol (and (fboundp x) + (setf fun (fdefinition x) + position (function-position fun)))) + (function (setf fun x position (function-position x)))) + (values fun position))) + +(defun frame-decode-env (frame) + (let ((functions '()) + (blocks '()) + (variables '())) + (setf frame (si::decode-ihs-env (second frame))) + (dolist (record frame) + (let* ((record0 (car record)) + (record1 (cdr record))) + (cond ((or (symbolp record0) (stringp record0)) + (setq variables (acons record0 record1 variables))) + ((not (mkcl:fixnump record0)) + (push record1 functions)) + ((symbolp record1) + (push record1 blocks)) + (t + )))) + (values functions blocks variables))) + +(defimplementation print-frame (frame stream) + (let ((function (first frame))) + (let ((fname +;;; (cond ((symbolp function) function) +;;; ((si:instancep function) (slot-value function 'name)) +;;; ((compiled-function-p function) +;;; (or (si::compiled-function-name function) 'lambda)) +;;; (t :zombi)) + (si::get-fname function) + )) + (if (eq fname 'si::bytecode) + (format stream "~A [Evaluation of: ~S]" + fname (function-lambda-expression function)) + (format stream "~A" fname) + ) + (when (si::closurep function) + (format stream + ", closure generated from ~A" + (si::get-fname (si:closure-producer function))) + ) + ) + ) + ) + +(defimplementation frame-source-location (frame-number) + (nth-value 1 (frame-function (elt *backtrace* frame-number)))) + +(defimplementation frame-catch-tags (frame-number) + (third (elt *backtrace* frame-number))) + +(defimplementation frame-locals (frame-number) + (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) + with i = 0 + collect (list :name name :id (prog1 i (incf i)) :value value))) + +(defimplementation frame-var-value (frame-number var-id) + (cdr (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number))) var-id))) + +(defimplementation disassemble-frame (frame-number) + (let ((fun (frame-fun (elt *backtrace* frame-number)))) + (disassemble fun))) + +(defimplementation eval-in-frame (form frame-number) + (let ((env (second (elt *backtrace* frame-number)))) + (si:eval-in-env form env))) + +#| +(defimplementation gdb-initial-commands () + ;; These signals are used by the GC. + #+linux '("handle SIGPWR noprint nostop" + "handle SIGXCPU noprint nostop")) + +(defimplementation command-line-args () + (loop for n from 0 below (si:argc) collect (si:argv n))) +|# + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + ; ecl clos support leaves some to be desired + (cond + ((streamp o) + (list* + (format nil "~S is an ordinary stream~%" o) + (append + (list + "Open for " + (cond + ((ignore-errors (interactive-stream-p o)) "Interactive") + ((and (input-stream-p o) (output-stream-p o)) "Input and output") + ((input-stream-p o) "Input") + ((output-stream-p o) "Output")) + `(:newline) `(:newline)) + (label-value-line* + ("Element type" (stream-element-type o)) + ("External format" (stream-external-format o))) + (ignore-errors (label-value-line* + ("Broadcast streams" (broadcast-stream-streams o)))) + (ignore-errors (label-value-line* + ("Concatenated streams" (concatenated-stream-streams o)))) + (ignore-errors (label-value-line* + ("Echo input stream" (echo-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Echo output stream" (echo-stream-output-stream o)))) + (ignore-errors (label-value-line* + ("Output String" (get-output-stream-string o)))) + (ignore-errors (label-value-line* + ("Synonym symbol" (synonym-stream-symbol o)))) + (ignore-errors (label-value-line* + ("Input stream" (two-way-stream-input-stream o)))) + (ignore-errors (label-value-line* + ("Output stream" (two-way-stream-output-stream o))))))) + ((si:instancep o) ;;t + (let* ((cl (si:instance-class o)) + (slots (clos::class-slots cl))) + (list* (format nil "~S is an instance of class ~A~%" + o (clos::class-name cl)) + (loop for x in slots append + (let* ((name (clos::slot-definition-name x)) + (value (if (slot-boundp o name) + (clos::slot-value o name) + "Unbound" + ))) + (list + (format nil "~S: " name) + `(:value ,value) + `(:newline))))))) + (t (list (format nil "~A" o))))) + +;;;; Definitions + +(defimplementation find-definitions (name) + (if (fboundp name) + (let ((tmp (find-source-location (symbol-function name)))) + `(((defun ,name) ,tmp))))) + +(defimplementation find-source-location (obj) + (setf *tmp* obj) + (or + (typecase obj + (function + (multiple-value-bind (file pos) (ignore-errors (si::compiled-function-file obj)) + (if (and file pos) + (make-location + `(:file ,(if (stringp file) file (namestring file))) + `(:end-position ,pos) ;; `(:position ,pos) + `(:snippet + ,(with-open-file (s file) + (file-position s pos) + (skip-comments-and-whitespace s) + (read-snippet s)))))))) + `(:error (format nil "Source definition of ~S not found" obj)))) + +;;;; Profiling + + +(eval-when (:compile-toplevel :load-toplevel) + ;; At compile-time we need access to the profile package for the + ;; the following code to be read properly. + ;; It is a bit a shame we have to load the entire module to get that. + (require 'profile)) + + +(defimplementation profile (fname) + (when fname (eval `(profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (profile:unprofile-all) + "All functions unprofiled.") + +(defimplementation profile-report () + (profile:report)) + +(defimplementation profile-reset () + (profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(profile:profile ,(package-name (find-package package))))) + + +;;;; Threads + +(defvar *thread-id-counter* 0) + +(defvar *thread-id-counter-lock* + (mt:make-lock :name "thread id counter lock")) + +(defun next-thread-id () + (mt:with-lock (*thread-id-counter-lock*) + (incf *thread-id-counter*)) + ) + +(defparameter *thread-id-map* (make-hash-table)) +(defparameter *id-thread-map* (make-hash-table)) + +(defvar *thread-id-map-lock* + (mt:make-lock :name "thread id map lock")) + +(defparameter +default-thread-local-variables+ + '(*macroexpand-hook* + *default-pathname-defaults* + *readtable* + *random-state* + *compile-print* + *compile-verbose* + *load-print* + *load-verbose* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pprint-dispatch* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + )) + +(defun thread-local-default-bindings () + (let (local) + (dolist (var +default-thread-local-variables+ local) + (setq local (acons var (symbol-value var) local)) + ))) + +;; mkcl doesn't have weak pointers +(defimplementation spawn (fn &key name initial-bindings) + (let* ((local-defaults (thread-local-default-bindings)) + (thread + ;;(mt:make-thread :name name) + (mt:make-thread :name name + :initial-bindings (nconc initial-bindings + local-defaults)) + ) + (id (next-thread-id))) + (mt:with-lock (*thread-id-map-lock*) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id)) + (mt:thread-preset + thread + #'(lambda () + (unwind-protect + (progn + ;;(format t "~&Starting thread: ~S.~%" name) (finish-output) + (mt:thread-detach nil) + (funcall fn)) + (progn + ;;(format t "~&Wrapping up thread: ~S.~%" name) (finish-output) + (mt:with-lock (*thread-id-map-lock*) + (remhash thread *id-thread-map*) + (remhash id *thread-id-map*)) + ;;(format t "~&Finished thread: ~S~%" name) (finish-output) + )))) + (mt:thread-enable thread) + (mt:thread-yield) + thread + )) + +(defimplementation thread-id (thread) + (block thread-id + (mt:with-lock (*thread-id-map-lock*) + (or (gethash thread *id-thread-map*) + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) thread) + (setf (gethash thread *id-thread-map*) id) + id))))) + +(defimplementation find-thread (id) + (mt:with-lock (*thread-id-map-lock*) + (gethash id *thread-id-map*))) + +(defimplementation thread-name (thread) + (mt:thread-name thread)) + +(defimplementation thread-status (thread) + (if (mt:thread-active-p thread) + "RUNNING" + "STOPPED")) + +(defimplementation make-lock (&key name) + (mt:make-lock :name name :recursive t)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (mt:with-lock (lock) (funcall function))) + +(defimplementation current-thread () + mt:*thread*) + +(defimplementation all-threads () + (mt:all-threads)) + +(defimplementation interrupt-thread (thread fn) + (mt:interrupt-thread thread fn)) + +(defimplementation kill-thread (thread) + (mt:interrupt-thread thread #'mt:terminate-thread) + ) + +(defimplementation thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defvar *mailbox-lock* (mt:make-lock :name "mailbox lock")) +(defvar *mailboxes* (list)) +(declaim (type list *mailboxes*)) + +(defstruct (mailbox (:conc-name mailbox.)) + thread + locked-by + (mutex (mt:make-lock :name "thread mailbox")) + (semaphore (mt:make-semaphore)) + (queue '() :type list)) + +(defun mailbox (thread) + "Return THREAD's mailbox." + (mt:with-lock (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + +(defimplementation send (thread message) + (handler-case + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) +;; (mt:interrupt-thread +;; thread +;; (lambda () +;; (mt:with-lock (mutex) +;; (setf (mailbox.queue mbox) +;; (nconc (mailbox.queue mbox) (list message)))))) + +;; (format t "~&! thread = ~S~% thread = ~S~% message = ~S~%" +;; mt:*thread* thread message) (finish-output) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + ;;(format t "*") (finish-output) + (handler-case + (mt:semaphore-signal (mailbox.semaphore mbox)) + (condition (condition) + (format t "Something went bad with semaphore-signal ~A" condition) (finish-output) + ;;(break) + )) + (setf (mailbox.locked-by mbox) nil) + ) + ;;(format t "+") (finish-output) + ) + (condition (condition) + (format t "~&Error in send: ~S~%" condition) (finish-output)) + ) + ) + +;; (defimplementation receive () +;; (block got-mail +;; (let* ((mbox (mailbox mt:*thread*)) +;; (mutex (mailbox.mutex mbox))) +;; (loop +;; (mt:with-lock (mutex) +;; (if (mailbox.queue mbox) +;; (return-from got-mail (pop (mailbox.queue mbox))))) +;; ;;interrupt-thread will halt this if it takes longer than 1sec +;; (sleep 1))))) + + +(defimplementation receive-if (test &optional timeout) + (handler-case + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + got-one) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-slime-interrupts) + ;;(format t "~&: ~S~%" mt:*thread*) (finish-output) + (handler-case + (setq got-one (mt:semaphore-wait (mailbox.semaphore mbox) 2)) + (condition (condition) + (format t "~&In (slynk-mkcl) receive-if: Something went bad with semaphore-wait ~A~%" condition) + (finish-output) + nil + ) + ) + (mt:with-lock (mutex) + (setf (mailbox.locked-by mbox) mt:*thread*) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (setf (mailbox.locked-by mbox) nil) + ;;(format t "~&thread ~S received: ~S~%" mt:*thread* (car tail)) + (return (car tail)))) + (setf (mailbox.locked-by mbox) nil) + ) + + ;;(format t "/ ~S~%" mt:*thread*) (finish-output) + (when (eq timeout t) (return (values nil t))) +;; (unless got-one +;; (format t "~&In (slynk-mkcl) receive-if: semaphore-wait timed out!~%")) + ) + ) + (condition (condition) + (format t "~&Error in (slynk-mkcl) receive-if: ~S, ~A~%" condition condition) (finish-output) + nil + ) + ) + ) + + +(defmethod stream-finish-output ((stream stream)) + (finish-output stream)) + + +;; + +;;#+windows +(defimplementation doze-in-repl () + (setq *inferior-lisp-sleeping-post* (mt:make-semaphore)) + ;;(loop (sleep 1)) + (mt:semaphore-wait *inferior-lisp-sleeping-post*) + (mk-ext:quit :verbose t) + ) + blob - /dev/null blob + d1a782b4b282315258335166195a0f4721f8c8c2 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/sbcl.lisp @@ -0,0 +1,2024 @@ +;;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-sbcl.lisp --- SLY backend for SBCL. +;;; +;;; Created 2003, Daniel Barlow +;;; +;;; This code has been placed in the Public Domain. All warranties are +;;; disclaimed. + +;;; Requires the SB-INTROSPECT contrib. + +;;; Administrivia + +(defpackage slynk-sbcl + (:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache) + (:export + #:with-sbcl-version>=)) + +(in-package slynk-sbcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'sb-bsd-sockets) + (require 'sb-introspect) + (require 'sb-posix) + (require 'sb-cltl2)) + +(declaim (optimize (debug 2) + (sb-c::insert-step-conditions 0) + (sb-c::insert-debug-catch 0))) + +;;; backwards compability tests + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Generate a form suitable for testing for stepper support (0.9.17) + ;; with #+. + (defun sbcl-with-new-stepper-p () + (with-symbol 'enable-stepping 'sb-impl)) + ;; Ditto for weak hash-tables + (defun sbcl-with-weak-hash-tables () + (with-symbol 'hash-table-weakness 'sb-ext)) + ;; And for xref support (1.0.1) + (defun sbcl-with-xref-p () + (with-symbol 'who-calls 'sb-introspect)) + ;; ... for restart-frame support (1.0.2) + (defun sbcl-with-restart-frame () + (with-symbol 'frame-has-debug-tag-p 'sb-debug)) + ;; ... for :setf :inverse info (1.1.17) + (defun sbcl-with-setf-inverse-meta-info () + (boolean-to-feature-expression + ;; going through FIND-SYMBOL since META-INFO was renamed from + ;; TYPE-INFO in 1.2.10. + (let ((sym (find-symbol "META-INFO" "SB-C"))) + (and sym + (fboundp sym) + (funcall sym :setf :inverse ())))))) + +;;; slynk-mop + +(import-slynk-mop-symbols :sb-mop '(:slot-definition-documentation)) + +(defun slynk-mop:slot-definition-documentation (slot) + (sb-pcl::documentation slot t)) + +;; stream support + +(defimplementation gray-package-name () + "SB-GRAY") + +;; Pretty printer calls this, apparently +(defmethod sb-gray:stream-line-length + ((s sb-gray:fundamental-character-input-stream)) + nil) + +;;; Connection info + +(defimplementation lisp-implementation-type-name () + "sbcl") + +;; Declare return type explicitly to shut up STYLE-WARNINGS about +;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below. +(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid)) +(defimplementation getpid () + (sb-posix:getpid)) + +;;; UTF8 + +(defimplementation string-to-utf8 (string) + (sb-ext:string-to-octets string :external-format '(:utf8 :replacement + #+sb-unicode #\Replacement_Character + #-sb-unicode #\? ))) + +(defimplementation utf8-to-string (octets) + (sb-ext:octets-to-string octets :external-format '(:utf8 :replacement + #+sb-unicode #\Replacement_Character + #-sb-unicode #\? ))) + +;;; TCP Server + +(defimplementation preferred-communication-style () + (cond + ;; fixme: when SBCL/win32 gains better select() support, remove + ;; this. + ((member :sb-thread *features*) :spawn) + ((member :win32 *features*) nil) + (t :fd-handler))) + + +(defun resolve-hostname (host) + "Returns valid IPv4 or IPv6 address for the host." + ;; get all IPv4 and IPv6 addresses as a list + (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host))) + ;; remove protocols for which we don't have an address + (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents))) + ;; Return the first one or nil, + ;; but actually, it shouln't return nil, because + ;; get-host-by-name will signal NAME-SERVICE-ERROR condition + ;; if there isn't any address for the host. + (first addresses))) + + +(defimplementation create-socket (host port &key backlog) + (let* ((host-ent (resolve-hostname host)) + (socket (make-instance (cond #+#.(slynk-backend:with-symbol 'inet6-socket 'sb-bsd-sockets) + ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10) + 'sb-bsd-sockets:inet6-socket) + (t + 'sb-bsd-sockets:inet-socket)) + :type :stream + :protocol :tcp))) + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) + (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port) + + (sb-bsd-sockets:socket-listen socket (or backlog 5)) + socket)) + +(defimplementation local-port (socket) + (nth-value 1 (sb-bsd-sockets:socket-name socket))) + +(defimplementation close-socket (socket) + (sb-sys:invalidate-descriptor (socket-fd socket)) + (sb-bsd-sockets:socket-close socket)) + +(defimplementation accept-connection (socket &key + external-format + buffering timeout) + (declare (ignore timeout)) + (make-socket-io-stream (accept socket) external-format + (ecase buffering + ((t :full) :full) + ((nil :none) :none) + ((:line) :line)))) + + +;; The SIGIO stuff should probably be removed as it's unlikey that +;; anybody uses it. +#-win32 +(progn + (defimplementation install-sigint-handler (function) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (&rest args) + (declare (ignore args)) + (sb-sys:invoke-interruption + (lambda () + (sb-sys:with-interrupts + (funcall function))))))) + + (defvar *sigio-handlers* '() + "List of (key . fn) pairs to be called on SIGIO.") + + (defun sigio-handler (signal code scp) + (declare (ignore signal code scp)) + (sb-sys:with-interrupts + (mapc (lambda (handler) + (funcall (the function (cdr handler)))) + *sigio-handlers*))) + + (defun set-sigio-handler () + (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler)) + + (defun enable-sigio-on-fd (fd) + (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async) + (sb-posix::fcntl fd sb-posix::f-setown (getpid)) + (values)) + + (defimplementation add-sigio-handler (socket fn) + (set-sigio-handler) + (let ((fd (socket-fd socket))) + (enable-sigio-on-fd fd) + (push (cons fd fn) *sigio-handlers*))) + + (defimplementation remove-sigio-handlers (socket) + (let ((fd (socket-fd socket))) + (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car)) + (sb-sys:invalidate-descriptor fd)) + (close socket))) + + +(defimplementation add-fd-handler (socket fun) + (let ((fd (socket-fd socket)) + (handler nil)) + (labels ((add () + (setq handler (sb-sys:add-fd-handler fd :input #'run))) + (run (fd) + (sb-sys:remove-fd-handler handler) ; prevent recursion + (unwind-protect + (funcall fun) + (when (sb-unix:unix-fstat fd) ; still open? + (add))))) + (add)))) + +(defimplementation remove-fd-handlers (socket) + (sb-sys:invalidate-descriptor (socket-fd socket))) + +(defimplementation socket-fd (socket) + (etypecase socket + (fixnum socket) + (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) + (file-stream (sb-sys:fd-stream-fd socket)))) + +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + +(defvar *wait-for-input-called*) + +(defimplementation wait-for-input (streams &optional timeout) + (assert (member timeout '(nil t))) + (when (boundp '*wait-for-input-called*) + (setq *wait-for-input-called* t)) + (let ((*wait-for-input-called* nil)) + (loop + (let ((ready (remove-if-not #'input-ready-p streams))) + (when ready (return ready))) + (when (check-sly-interrupts) + (return :interrupt)) + (when *wait-for-input-called* + (return :interrupt)) + (when timeout + (return nil)) + (sleep 0.1)))) + +(defun fd-stream-input-buffer-empty-p (stream) + (let ((buffer (sb-impl::fd-stream-ibuf stream))) + (or (not buffer) + (= (sb-impl::buffer-head buffer) + (sb-impl::buffer-tail buffer))))) + +#-win32 +(defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + #+#.(slynk-backend:with-symbol 'fd-stream-fd-type 'sb-impl) + (eq :regular (sb-impl::fd-stream-fd-type stream)) + (not (sb-impl::sysread-may-block-p stream)))) + +#+win32 +(progn + (defun input-ready-p (stream) + (or (not (fd-stream-input-buffer-empty-p stream)) + (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream))))) + + (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event) + sb-win32:handle) + + (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event) + sb-alien:int + (event sb-win32:handle)) + + (defconstant +fd-read+ #.(ash 1 0)) + (defconstant +fd-close+ #.(ash 1 5)) + + (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select) + sb-alien:int + (fd sb-alien:int) + (handle sb-win32:handle) + (mask sb-alien:long)) + + (sb-alien:load-shared-object "kernel32.dll") + (sb-alien:define-alien-routine ("WaitForSingleObjectEx" + wait-for-single-object-ex) + sb-alien:int + (event sb-win32:handle) + (milliseconds sb-alien:long) + (alertable sb-alien:int)) + + ;; see SB-WIN32:HANDLE-LISTEN + (defun handle-listen (handle) + (sb-alien:with-alien ((avail sb-win32:dword) + (buf (array char #.sb-win32::input-record-size))) + (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil + (sb-alien:alien-sap + (sb-alien:addr avail)) + nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (sb-win32:peek-console-input handle + (sb-alien:alien-sap buf) + sb-win32::input-record-size + (sb-alien:alien-sap + (sb-alien:addr avail)))) + (return-from handle-listen (plusp avail)))) + + (let ((event (wsa-create-event))) + (wsa-event-select handle event (logior +fd-read+ +fd-close+)) + (let ((val (wait-for-single-object-ex event 0 0))) + (wsa-close-event event) + (unless (= val -1) + (return-from handle-listen (zerop val))))) + + nil) + + ) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix") + (:us-ascii "us-ascii" "us-ascii-unix"))) + +;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, +;; 2008-08-22. +(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname))) + +(defimplementation filename-to-pathname (filename) + (sb-ext:parse-native-namestring filename *physical-pathname-host*)) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defimplementation set-default-directory (directory) + (let ((directory (truename (merge-pathnames directory)))) + (sb-posix:chdir directory) + (setf *default-pathname-defaults* directory) + (default-directory))) + +(defun make-socket-io-stream (socket external-format buffering) + (let ((args `(:output t + :input t + :element-type ,(if external-format + 'character + '(unsigned-byte 8)) + :buffering ,buffering + ,@(cond ((and external-format (sb-int:featurep :sb-unicode)) + `(:external-format ,external-format)) + (t '())) + :serve-events ,(eq :fd-handler + (slynk-value '*communication-style* t)) + ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS + ;; argument. + :allow-other-keys t))) + (apply #'sb-bsd-sockets:socket-make-stream socket args))) + +(defun accept (socket) + "Like socket-accept, but retry on EAGAIN." + (loop (handler-case + (return (sb-bsd-sockets:socket-accept socket)) + (sb-bsd-sockets:interrupted-error ())))) + + +;;;; Support for SBCL syntax + +;;; SBCL's source code is riddled with #! reader macros. Also symbols +;;; containing `!' have special meaning. We have to work long and +;;; hard to be able to read the source. To deal with #! reader +;;; macros, we use a special readtable. The special symbols are +;;; converted by a condition handler. + +(defun feature-in-list-p (feature list) + (etypecase feature + (symbol (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (feature-in-list-p subfeature list))) + ;; Don't use ECASE since SBCL also has :host-feature, + ;; don't need to handle it or anything else appearing in + ;; the future or in erronous code. + (case (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (destructuring-bind (e) (cdr feature) + (not (subfeature-in-list-p e))))))))) + +(defun shebang-reader (stream sub-character infix-parameter) + (declare (ignore sub-character)) + (when infix-parameter + (error "illegal read syntax: #~D!" infix-parameter)) + (let ((next-char (read-char stream))) + (unless (find next-char "+-") + (error "illegal read syntax: #!~C" next-char)) + ;; When test is not satisfied + ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then + ;; would become "unless test is satisfied".. + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *features*) + not-p + (not not-p))) + ;; Read (and discard) a form from input. + (let ((*read-suppress* t)) + (read stream t nil t)))) + (values)) + +(defvar *shebang-readtable* + (let ((*readtable* (copy-readtable nil))) + (set-dispatch-macro-character #\# #\! + (lambda (s c n) (shebang-reader s c n)) + *readtable*) + *readtable*)) + +(defun shebang-readtable () + *shebang-readtable*) + +(defun sbcl-package-p (package) + (let ((name (package-name package))) + (eql (mismatch "SB-" name) 3))) + +(defun sbcl-source-file-p (filename) + (when filename + (loop for (nil pattern) in (logical-pathname-translations "SYS") + thereis (pathname-match-p filename pattern)))) + +(defun guess-readtable-for-filename (filename) + (if (sbcl-source-file-p filename) + (shebang-readtable) + *readtable*)) + +(defvar *debootstrap-packages* t) + +(defun call-with-debootstrapping (fun) + (handler-bind ((sb-int:bootstrap-package-not-found + #'sb-int:debootstrap-package)) + (funcall fun))) + +(defmacro with-debootstrapping (&body body) + `(call-with-debootstrapping (lambda () ,@body))) + +(defimplementation call-with-syntax-hooks (fn) + (cond ((and *debootstrap-packages* + (sbcl-package-p *package*)) + (with-debootstrapping (funcall fn))) + (t + (funcall fn)))) + +(defimplementation default-readtable-alist () + (let ((readtable (shebang-readtable))) + (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages)) + collect (cons (package-name p) readtable)))) + +;;; Packages + +#+#.(slynk-backend:with-symbol 'package-local-nicknames 'sb-ext) +(defimplementation package-local-nicknames (package) + (sb-ext:package-local-nicknames package)) + +;;; Utilities + +(defun slynk-value (name &optional errorp) + ;; Easy way to refer to symbol values in SLYNK, which doesn't yet exist when + ;; this is file is loaded. + (let ((symbol (find-symbol (string name) :slynk))) + (if (and symbol (or errorp (boundp symbol))) + (symbol-value symbol) + (when errorp + (error "~S does not exist in SLYNK." name))))) + +(defun sbcl-version>= (&rest subversions) + #+#.(slynk-backend:with-symbol 'assert-version->= 'sb-ext) + (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t)) + #-#.(slynk-backend:with-symbol 'assert-version->= 'sb-ext) + nil) + +(defmacro with-sbcl-version>= (&rest subversions) + `(if (sbcl-version>= ,@subversions) + '(:and) '(:or))) + +#+#.(slynk-backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-lambda-list fname)) + +#-#.(slynk-backend:with-symbol 'function-lambda-list 'sb-introspect) +(defimplementation arglist (fname) + (sb-introspect:function-arglist fname)) + +(defimplementation function-name (f) + (check-type f function) + (sb-impl::%fun-name f)) + +(defmethod declaration-arglist ((decl-identifier (eql 'optimize))) + (flet ((ensure-list (thing) (if (listp thing) thing (list thing)))) + (let* ((flags (sb-cltl2:declaration-information decl-identifier))) + (if flags + ;; Symbols aren't printed with package qualifiers, but the + ;; FLAGS would have to be fully qualified when used inside a + ;; declaration. So we strip those as long as there's no + ;; better way. (FIXME) + `(&any ,@(remove-if-not + #'(lambda (qualifier) + (find-symbol (symbol-name (first qualifier)) :cl)) + flags :key #'ensure-list)) + (call-next-method))))) + +#+#.(slynk-backend:with-symbol 'deftype-lambda-list 'sb-introspect) +(defmethod type-specifier-arglist :around (typespec-operator) + (multiple-value-bind (arglist foundp) + (sb-introspect:deftype-lambda-list typespec-operator) + (if foundp arglist (call-next-method)))) + +(defimplementation type-specifier-p (symbol) + (or (sb-ext:valid-type-specifier-p symbol) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(defvar *buffer-name* nil) +(defvar *buffer-tmpfile* nil) +(defvar *buffer-offset*) +(defvar *buffer-substring* nil) + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning. +This traps all compiler conditions at a lower-level than using +C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to +craft our own error messages, which can omit a lot of redundant +information." + (unless (or (eq condition *previous-compiler-condition*)) + ;; First resignal warnings, so that outer handlers -- which may choose to + ;; muffle this -- get a chance to run. + (when (typep condition 'warning) + (signal condition)) + (setq *previous-compiler-condition* condition) + (signal-compiler-condition (real-condition condition) + (sb-c::find-error-context nil)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (etypecase condition + (sb-ext:compiler-note :note) + (sb-c:compiler-error :error) + (reader-error :read-error) + (error :error) + #+#.(slynk-backend:with-symbol early-deprecation-warning sb-ext) + (sb-ext::early-deprecation-warning :early-deprecation-warning) + #+#.(slynk-backend:with-symbol late-deprecation-warning sb-ext) + (sb-ext::late-deprecation-warning :late-deprecation-warning) + #+#.(slynk-backend:with-symbol final-deprecation-warning sb-ext) + (sb-ext::final-deprecation-warning :final-deprecation-warning) + #+#.(slynk-backend:with-symbol redefinition-warning + sb-kernel) + (sb-kernel:redefinition-warning + :redefinition) + (style-warning :style-warning) + (warning :warning)) + :references (condition-references condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (compiler-note-location condition context))) + +(defun real-condition (condition) + "Return the encapsulated condition or CONDITION itself." + (typecase condition + (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition)) + (t condition))) + +(defun condition-references (condition) + (if (typep condition 'sb-int:reference-condition) + (externalize-reference + (sb-int:reference-condition-references condition)))) + +(defun compiler-note-location (condition context) + (flet ((bailout () + (return-from compiler-note-location + (make-error-location "No error location available")))) + (cond (context + (locate-compiler-note + (sb-c::compiler-error-context-file-name context) + (compiler-source-path context) + (sb-c::compiler-error-context-original-source context))) + ((typep condition 'reader-error) + (let* ((stream (stream-error-stream condition)) + ;; If STREAM is, for example, a STRING-INPUT-STREAM, + ;; an error will be signaled since PATHNAME only + ;; accepts a "stream associated with a file" which + ;; is a complicated predicate and hard to test + ;; portably. + (file (ignore-errors (pathname stream)))) + (unless (and file (open-stream-p stream)) + (bailout)) + (if (compiling-from-buffer-p file) + ;; The stream position for e.g. "comma not inside + ;; backquote" is at the character following the + ;; comma, :offset is 0-based, hence the 1-. + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (1- (file-position stream)))) + (progn + (assert (compiling-from-file-p file)) + ;; No 1- because :position is 1-based. + (make-location (list :file (namestring file)) + (list :position (file-position stream))))))) + (t (bailout))))) + +(defun compiling-from-buffer-p (filename) + (and *buffer-name* + ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P + ;; in LOCATE-COMPILER-NOTE, and allows handling nested + ;; compilation from eg. hitting C-C on (eval-when ... (require ..))). + ;; + ;; PROBE-FILE to handle tempfile directory being a symlink. + (pathnamep filename) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (and true1 (equal true1 true2))))) + +(defun compiling-from-file-p (filename) + (and (pathnamep filename) + (or (null *buffer-name*) + (null *buffer-tmpfile*) + (let ((true1 (probe-file filename)) + (true2 (probe-file *buffer-tmpfile*))) + (not (and true1 (equal true1 true2))))))) + +(defun compiling-from-generated-code-p (filename source) + (and (eq filename :lisp) (stringp source))) + +(defun locate-compiler-note (file source-path source) + (cond ((compiling-from-buffer-p file) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-offset* + (source-path-string-position + source-path *buffer-substring*)))) + ((compiling-from-file-p file) + (let ((position (source-path-file-position source-path file))) + (make-location (list :file (namestring file)) + (list :position (and position + (1+ position)))))) + ((compiling-from-generated-code-p file source) + (make-location (list :source-form source) + (list :position 1))) + (t + (error "unhandled case in compiler note ~S ~S ~S" + file source-path source)))) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. +When Emacs presents the message it already has the source popped up +and the source form highlighted. This makes much of the information in +the error-context redundant." + (let ((sb-int:*print-condition-references* nil)) + (princ-to-string condition))) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or sb-c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (sb-c::compiler-error-context-enclosing-source error-context) + (sb-c::compiler-error-context-source error-context))) + (and (or enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]" + enclosing source)))) + +(defun compiler-source-path (context) + "Return the source-path for the current compiler error. +Returns NIL if this cannot be determined by examining internal +compiler state." + (cond ((sb-c::node-p context) + (reverse + (sb-c::source-path-original-source + (sb-c::node-source-path context)))) + ((sb-c::compiler-error-context-p context) + (reverse + (sb-c::compiler-error-context-original-source-path context))))) + +(defimplementation call-with-compilation-hooks (function) + (declare (type function function)) + (handler-bind + ;; N.B. Even though these handlers are called HANDLE-FOO they + ;; actually decline, i.e. the signalling of the original + ;; condition continues upward. + ((sb-c:fatal-compiler-error #'handle-notification-condition) + (sb-c:compiler-error #'handle-notification-condition) + (sb-ext:compiler-note #'handle-notification-condition) + (error #'handle-notification-condition) + (warning #'handle-notification-condition)) + (funcall function))) + +;;; HACK: SBCL 1.2.12 shipped with a bug where +;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there +;;; were no policy restrictions in place. This workaround ensures the +;;; existence of at least one dummy restriction. +(handler-case (sb-ext:restrict-compiler-policy) + (error () (sb-ext:restrict-compiler-policy 'debug))) + +(defun compiler-policy (qualities) + "Return compiler policy qualities present in the QUALITIES alist. +QUALITIES is an alist with (quality . value)" + #+#.(slynk-backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop with policy = (sb-ext:restrict-compiler-policy) + for (quality) in qualities + collect (cons quality + (or (cdr (assoc quality policy)) + 0)))) + +(defun (setf compiler-policy) (policy) + (declare (ignorable policy)) + #+#.(slynk-backend:with-symbol 'restrict-compiler-policy 'sb-ext) + (loop for (qual . value) in policy + do (sb-ext:restrict-compiler-policy qual value))) + +(defmacro with-compiler-policy (policy &body body) + (let ((current-policy (gensym))) + `(let ((,current-policy (compiler-policy ,policy))) + (setf (compiler-policy) ,policy) + (unwind-protect (progn ,@body) + (setf (compiler-policy) ,current-policy))))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (multiple-value-bind (output-file warnings-p failure-p) + (with-compiler-policy policy + (with-compilation-hooks () + (compile-file input-file :output-file output-file + :external-format external-format))) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))) + +;;;; compile-string + +;;; We copy the string to a temporary file in order to get adequate +;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms +;;; which the previous approach using +;;; (compile nil `(lambda () ,(read-from-string string))) +;;; did not provide. + +(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + +(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam) + sb-alien:c-string + (dir sb-alien:c-string) + (prefix sb-alien:c-string))) + +(defun temp-file-name () + "Return a temporary file name to compile strings into." + (tempnam nil "slime")) + +(defvar *trap-load-time-warnings* t) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore line column)) + (let ((*buffer-name* buffer) + (*buffer-offset* position) + (*buffer-substring* string) + (*buffer-tmpfile* (temp-file-name))) + (labels ((load-it (filename) + (cond (*trap-load-time-warnings* + (with-compilation-hooks () (load filename))) + (t (load filename)))) + (cf () + (with-compiler-policy policy + (with-compilation-unit + (:source-plist (list :emacs-buffer buffer + :emacs-filename filename + :emacs-package (package-name *package*) + :emacs-position position + :emacs-string string) + :source-namestring filename + :allow-other-keys t) + (compile-file *buffer-tmpfile* :external-format :utf-8))))) + (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error + :external-format :utf-8) + (write-string string s)) + (unwind-protect + (multiple-value-bind (output-file warningsp failurep) + (with-compilation-hooks () (cf)) + (declare (ignore warningsp)) + (when output-file + (load-it output-file)) + (not failurep)) + (ignore-errors + (delete-file *buffer-tmpfile*) + (delete-file (compile-file-pathname *buffer-tmpfile*))))))) + +;;;; Definitions + +(defparameter *definition-types* + '(:variable defvar + :constant defconstant + :type deftype + :symbol-macro define-symbol-macro + :macro defmacro + :compiler-macro define-compiler-macro + :function defun + :generic-function defgeneric + :method defmethod + :setf-expander define-setf-expander + :structure defstruct + :condition define-condition + :class defclass + :method-combination define-method-combination + :package defpackage + :transform :deftransform + :optimizer :defoptimizer + :vop :define-vop + :source-transform :define-source-transform + :ir1-convert :def-ir1-translator + :declaration declaim + :alien-type :define-alien-type) + "Map SB-INTROSPECT definition type names to SLY-friendly forms") + +(defun definition-specifier (type) + "Return a pretty specifier for NAME representing a definition of type TYPE." + (getf *definition-types* type)) + +(defun make-dspec (type name source-location) + (list* (definition-specifier type) + name + (sb-introspect::definition-source-description source-location))) + +(defimplementation find-definitions (name) + (loop for type in *definition-types* by #'cddr + for defsrcs = (sb-introspect:find-definition-sources-by-name name type) + for filtered-defsrcs = (if (eq type :generic-function) + (remove :invalid defsrcs + :key #'categorize-definition-source) + defsrcs) + append (loop for defsrc in filtered-defsrcs collect + (list (make-dspec type name defsrc) + (converting-errors-to-error-location + (definition-source-for-emacs defsrc + type name)))))) + +(defimplementation find-source-location (obj) + (flet ((general-type-of (obj) + (typecase obj + (method :method) + (generic-function :generic-function) + (function :function) + (structure-class :structure-class) + (class :class) + (method-combination :method-combination) + (package :package) + (condition :condition) + (structure-object :structure-object) + (standard-object :standard-object) + (t :thing))) + (to-string (obj) + (typecase obj + ;; Packages are possibly named entities. + (package (princ-to-string obj)) + ((or structure-object standard-object condition) + (with-output-to-string (s) + (print-unreadable-object (obj s :type t :identity t)))) + (t (princ-to-string obj))))) + (converting-errors-to-error-location + (let ((defsrc (sb-introspect:find-definition-source obj))) + (definition-source-for-emacs defsrc + (general-type-of obj) + (to-string obj)))))) + +(defmacro with-definition-source ((&rest names) obj &body body) + "Like with-slots but works only for structs." + (flet ((reader (slot) + ;; Use read-from-string instead of intern so that + ;; conc-name can be a string such as ext:struct- and not + ;; cause errors and not force interning ext::struct- + (read-from-string + (concatenate 'string "sb-introspect:definition-source-" + (string slot))))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defun categorize-definition-source (definition-source) + (with-definition-source (pathname form-path character-offset plist) + definition-source + (let ((file-p (and pathname (probe-file pathname) + (or form-path character-offset)))) + (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file) + ((getf plist :emacs-buffer) :buffer) + (file-p :file) + (pathname :file-without-position) + (t :invalid))))) + +#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun form-number-position (definition-source stream) + (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source))) + (form-number (sb-introspect:definition-source-form-number definition-source))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun file-form-number-position (definition-source) + (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source)) + (filename (sb-introspect:definition-source-pathname definition-source)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (form-number-position definition-source s))))) + +#+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect) +(defun string-form-number-position (definition-source string) + (with-input-from-string (s string) + (form-number-position definition-source s))) + +(defun definition-source-buffer-location (definition-source) + (with-definition-source (form-path character-offset plist) definition-source + (destructuring-bind (&key emacs-buffer emacs-position emacs-directory + emacs-string &allow-other-keys) + plist + (let ((*readtable* (guess-readtable-for-filename emacs-directory)) + start + end) + (with-debootstrapping + (or + (and form-path + (or + #+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect) + (setf (values start end) + (and (sb-introspect:definition-source-form-number definition-source) + (string-form-number-position definition-source emacs-string))) + (setf (values start end) + (source-path-string-position form-path emacs-string)))) + (setf start character-offset + end most-positive-fixnum))) + (make-location + `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,start) + `(:snippet + ,(subseq emacs-string + start + (min end (+ start *source-snippet-size*))))))))) + +(defun definition-source-file-location (definition-source) + (with-definition-source (pathname form-path character-offset plist + file-write-date) definition-source + (let* ((namestring (namestring (translate-logical-pathname pathname))) + (pos (or (and form-path + (or + #+#.(slynk-backend:with-symbol 'definition-source-form-number 'sb-introspect) + (and (sb-introspect:definition-source-form-number definition-source) + (ignore-errors (file-form-number-position definition-source))) + (ignore-errors + (source-file-position namestring file-write-date + form-path)))) + character-offset)) + (snippet (source-hint-snippet namestring file-write-date pos))) + (make-location `(:file ,namestring) + ;; /file positions/ in Common Lisp start from + ;; 0, buffer positions in Emacs start from 1. + `(:position ,(1+ pos)) + `(:snippet ,snippet))))) + +(defun definition-source-buffer-and-file-location (definition-source) + (let ((buffer (definition-source-buffer-location definition-source)) + (file (definition-source-file-location definition-source))) + (make-location (list :buffer-and-file + (cadr (location-buffer buffer)) + (cadr (location-buffer file))) + (location-position buffer) + (location-hints buffer)))) + +(defun definition-source-for-emacs (definition-source type name) + (with-definition-source (pathname form-path character-offset plist + file-write-date) + definition-source + (ecase (categorize-definition-source definition-source) + (:buffer-and-file + (definition-source-buffer-and-file-location definition-source)) + (:buffer + (definition-source-buffer-location definition-source)) + (:file + (definition-source-file-location definition-source)) + (:file-without-position + (make-location `(:file ,(namestring + (translate-logical-pathname pathname))) + '(:position 1) + (when (eql type :function) + `(:snippet ,(format nil "(defun ~a " + (symbol-name name)))))) + (:invalid + (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~ + meaningful information." + type name))))) + +(defun source-file-position (filename write-date form-path) + (let ((source (get-source-code filename write-date)) + (*readtable* (guess-readtable-for-filename filename))) + (with-debootstrapping + (source-path-string-position form-path source)))) + +(defun source-hint-snippet (filename write-date position) + (read-snippet-from-string (get-source-code filename write-date) position)) + +(defun function-source-location (function &optional name) + (declare (type function function)) + (definition-source-for-emacs (sb-introspect:find-definition-source function) + :function + (or name (function-name function)))) + +(defun setf-expander (symbol) + (or + #+#.(slynk-sbcl::sbcl-with-setf-inverse-meta-info) + (sb-int:info :setf :inverse symbol) + (sb-int:info :setf :expander symbol))) + +(defimplementation describe-symbol-for-emacs (symbol) + "Return a plist describing SYMBOL. +Return NIL if the symbol is unbound." + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (sb-int:info :variable :kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((typep (fdefinition symbol) 'generic-function) + :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (and (setf-expander symbol) + (doc 'setf))) + (maybe-push + :type (if (sb-int:info :type :kind symbol) + (doc 'type))) + result))) + +(defimplementation describe-definition (symbol type) + (case type + (:variable + (describe symbol)) + (:function + (describe (symbol-function symbol))) + (:setf + (describe (setf-expander symbol))) + (:class + (describe (find-class symbol))) + (:type + (describe (sb-kernel:values-specifier-type symbol))))) + +#+#.(slynk-sbcl::sbcl-with-xref-p) +(progn + (defmacro defxref (name &optional fn-name) + `(defimplementation ,name (what) + (sanitize-xrefs + (mapcar #'source-location-for-xref-data + (,(find-symbol (symbol-name (if fn-name + fn-name + name)) + "SB-INTROSPECT") + what))))) + (defxref who-calls) + (defxref who-binds) + (defxref who-sets) + (defxref who-references) + (defxref who-macroexpands) + #+#.(slynk-backend:with-symbol 'who-specializes-directly 'sb-introspect) + (defxref who-specializes who-specializes-directly)) + +(defun source-location-for-xref-data (xref-data) + (destructuring-bind (name . defsrc) xref-data + (list name (converting-errors-to-error-location + (definition-source-for-emacs defsrc 'function name))))) + +(defimplementation list-callers (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))) + +(defimplementation list-callees (symbol) + (let ((fn (fdefinition symbol))) + (sanitize-xrefs + (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))) + +(defun sanitize-xrefs (xrefs) + (remove-duplicates + (remove-if (lambda (f) + (member f (ignored-xref-function-names))) + (loop for entry in xrefs + for name = (car entry) + collect (if (and (consp name) + (member (car name) + '(sb-pcl::fast-method + sb-pcl::slow-method + sb-pcl::method))) + (cons (cons 'defmethod (cdr name)) + (cdr entry)) + entry)) + :key #'car) + :test (lambda (a b) + (and (eq (first a) (first b)) + (equal (second a) (second b)))))) + +(defun ignored-xref-function-names () + #-#.(slynk-sbcl::sbcl-with-new-stepper-p) + '(nil sb-c::step-form sb-c::step-values) + #+#.(slynk-sbcl::sbcl-with-new-stepper-p) + '(nil)) + +(defun function-dspec (fn) + "Describe where the function FN was defined. +Return a list of the form (NAME LOCATION)." + (let ((name (function-name fn))) + (list name (converting-errors-to-error-location + (function-source-location fn name))))) + +;;; macroexpansion + +(defimplementation macroexpand-all (form &optional env) + (sb-cltl2:macroexpand-all form env)) + + +;;; Debugging + +;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger +;;; than just a hook into BREAK. In particular, it'll make +;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLY-DB rather +;;; than the native debugger. That should probably be considered a +;;; feature. + +(defun make-invoke-debugger-hook (hook) + (when hook + #'(sb-int:named-lambda slynk-invoke-debugger-hook + (condition old-hook) + (if *debugger-hook* + nil ; decline, *DEBUGGER-HOOK* will be tried next. + (funcall hook condition old-hook))))) + +(defun set-break-hook (hook) + (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + +(defun call-with-break-hook (hook continuation) + (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))) + (funcall continuation))) + +(defimplementation install-debugger-globally (function) + (setq *debugger-hook* function) + (set-break-hook function)) + +(defimplementation condition-extras (condition) + (cond #+#.(slynk-sbcl::sbcl-with-new-stepper-p) + ((typep condition 'sb-impl::step-form-condition) + `((:show-frame-source 0))) + ((typep condition 'sb-int:reference-condition) + (let ((refs (sb-int:reference-condition-references condition))) + (if refs + `((:references ,(externalize-reference refs)))))))) + +(defun externalize-reference (ref) + (etypecase ref + (null nil) + (cons (cons (externalize-reference (car ref)) + (externalize-reference (cdr ref)))) + ((or string number) ref) + (symbol + (cond ((eq (symbol-package ref) (symbol-package :test)) + ref) + (t (symbol-name ref)))))) + +(defvar *sly-db-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (declare (type function debugger-loop-fn)) + (let ((*sly-db-stack-top* + (if (and (not *debug-slynk-backend*) + sb-debug:*stack-top-hint*) + #+#.(slynk-backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + (sb-debug::resolve-stack-top-hint) + #-#.(slynk-backend:with-symbol 'resolve-stack-top-hint 'sb-debug) + sb-debug:*stack-top-hint* + (sb-di:top-frame))) + (sb-debug:*stack-top-hint* nil)) + (handler-bind ((sb-di:debug-condition + (lambda (condition) + (signal 'sly-db-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +#+#.(slynk-sbcl::sbcl-with-new-stepper-p) +(progn + (defimplementation activate-stepping (frame) + (declare (ignore frame)) + (sb-impl::enable-stepping)) + (defimplementation sly-db-stepper-condition-p (condition) + (typep condition 'sb-ext:step-form-condition)) + (defimplementation sly-db-step-into () + (invoke-restart 'sb-ext:step-into)) + (defimplementation sly-db-step-next () + (invoke-restart 'sb-ext:step-next)) + (defimplementation sly-db-step-out () + (invoke-restart 'sb-ext:step-out))) + +(defimplementation call-with-debugger-hook (hook fun) + (let ((*debugger-hook* hook) + #+#.(slynk-sbcl::sbcl-with-new-stepper-p) + (sb-ext:*stepper-hook* + (lambda (condition) + (typecase condition + (sb-ext:step-form-condition + (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame))) + (sb-impl::invoke-debugger condition))))))) + (handler-bind (#+#.(slynk-sbcl::sbcl-with-new-stepper-p) + (sb-ext:step-condition #'sb-impl::invoke-stepper)) + (call-with-break-hook hook fun)))) + +(defun nth-frame (index) + (do ((frame *sly-db-stack-top* (sb-di:frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + "Return a list of frames starting with frame number START and +continuing to frame number END or, if END is nil, the last frame on the +stack." + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (sb-di:frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (sb-debug::print-frame-call frame stream + :allow-other-keys t + :emergency-best-effort t)) + +(defimplementation frame-restartable-p (frame) + #+#.(slynk-sbcl::sbcl-with-restart-frame) + (not (null (sb-debug:frame-has-debug-tag-p frame)))) + +(defimplementation frame-arguments (frame) + (multiple-value-bind (name args) + (sb-debug::frame-call (nth-frame frame)) + (declare (ignore name)) + (values-list args))) + +;;;; Code-location -> source-location translation + +;;; If debug-block info is avaibale, we determine the file position of +;;; the source-path for a code-location. If the code was compiled +;;; with C-c C-c, we have to search the position in the source string. +;;; If there's no debug-block info, we return the (less precise) +;;; source-location of the corresponding function. + +(defun code-location-source-location (code-location) + (let* ((dsource (sb-di:code-location-debug-source code-location)) + (plist (sb-c::debug-source-plist dsource)) + (package (getf plist :emacs-package)) + (*package* (or (and package + (find-package package)) + *package*))) + (if (getf plist :emacs-buffer) + (emacs-buffer-source-location code-location plist) + #+#.(slynk-backend:with-symbol 'debug-source-from 'sb-di) + (ecase (sb-di:debug-source-from dsource) + (:file (file-source-location code-location)) + (:lisp (lisp-source-location code-location))) + #-#.(slynk-backend:with-symbol 'debug-source-from 'sb-di) + (if (sb-di:debug-source-namestring dsource) + (file-source-location code-location) + (lisp-source-location code-location))))) + +;;; FIXME: The naming policy of source-location functions is a bit +;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the +;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co +;;; which returns the source location for a _code-location_. +;;; +;;; Maybe these should be named code-location-file-source-location, +;;; etc, turned into generic functions, or something. In the very +;;; least the names should indicate the main entry point vs. helper +;;; status. + +(defun file-source-location (code-location) + (if (code-location-has-debug-block-info-p code-location) + (source-file-source-location code-location) + (fallback-source-location code-location))) + +(defun fallback-source-location (code-location) + (let ((fun (code-location-debug-fun-fun code-location))) + (cond (fun (function-source-location fun)) + (t (error "Cannot find source location for: ~A " code-location))))) + +(defun lisp-source-location (code-location) + (let ((source (prin1-to-string + (sb-debug::code-location-source-form code-location 100))) + (condition (slynk-value '*slynk-debugger-condition*))) + (if (and (typep condition 'sb-impl::step-form-condition) + (search "SB-IMPL::WITH-STEPPING-ENABLED" source + :test #'char-equal) + (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal)) + ;; The initial form is utterly uninteresting -- and almost + ;; certainly right there in the REPL. + (make-error-location "Stepping...") + (make-location `(:source-form ,source) '(:position 1))))) + +(defun emacs-buffer-source-location (code-location plist) + (if (code-location-has-debug-block-info-p code-location) + (destructuring-bind (&key emacs-buffer emacs-position emacs-string + &allow-other-keys) + plist + (let* ((pos (string-source-position code-location emacs-string)) + (snipped (read-snippet-from-string emacs-string pos))) + (make-location `(:buffer ,emacs-buffer) + `(:offset ,emacs-position ,pos) + `(:snippet ,snipped)))) + (fallback-source-location code-location))) + +(defun source-file-source-location (code-location) + (let* ((code-date (code-location-debug-source-created code-location)) + (filename (code-location-debug-source-name code-location)) + (*readtable* (guess-readtable-for-filename filename)) + (source-code (get-source-code filename code-date))) + (with-debootstrapping + (with-input-from-string (s source-code) + (let* ((pos (stream-source-position code-location s)) + (snippet (read-snippet s pos))) + (make-location `(:file ,filename) + `(:position ,pos) + `(:snippet ,snippet))))))) + +(defun code-location-debug-source-name (code-location) + (namestring (truename (#.(slynk-backend:choose-symbol + 'sb-c 'debug-source-name + 'sb-c 'debug-source-namestring) + (sb-di::code-location-debug-source code-location))))) + +(defun code-location-debug-source-created (code-location) + (sb-c::debug-source-created + (sb-di::code-location-debug-source code-location))) + +(defun code-location-debug-fun-fun (code-location) + (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location))) + +(defun code-location-has-debug-block-info-p (code-location) + (handler-case + (progn (sb-di:code-location-debug-block code-location) + t) + (sb-di:no-debug-blocks () nil))) + +(defun stream-source-position (code-location stream) + (let* ((cloc (sb-debug::maybe-block-start-location code-location)) + (tlf-number (sb-di::code-location-toplevel-form-offset cloc)) + (form-number (sb-di::code-location-form-number cloc))) + (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream) + (let* ((path-table (sb-di::form-number-translations tlf 0)) + (path (cond ((<= (length path-table) form-number) + (warn "inconsistent form-number-translations") + (list 0)) + (t + (reverse (cdr (aref path-table form-number))))))) + (source-path-source-position path tlf pos-map))))) + +(defun string-source-position (code-location string) + (with-input-from-string (s string) + (stream-source-position code-location s))) + +;;; source-path-file-position and friends are in slynk-source-path-parser + +(defimplementation frame-source-location (index) + (converting-errors-to-error-location + (code-location-source-location + (sb-di:frame-code-location (nth-frame index))))) + +(defvar *keep-non-valid-locals* nil) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) + (loc (sb-di:frame-code-location frame)) + (vars (if *keep-non-valid-locals* + all-vars + (remove-if (lambda (var) + (ecase (sb-di:debug-var-validity var loc) + (:valid nil) + ((:invalid :unknown) t))) + all-vars))) + more-context + more-count) + (values (when vars + (loop for v across vars + unless + (case (debug-var-info v) + (:more-context + (setf more-context (debug-var-value v frame loc)) + t) + (:more-count + (setf more-count (debug-var-value v frame loc)) + t)) + collect v)) + more-context more-count))) + +(defun debug-var-value (var frame location) + (ecase (sb-di:debug-var-validity var location) + (:valid (sb-di:debug-var-value var frame)) + ((:invalid :unknown) ':))) + +(defun debug-var-info (var) + ;; Introduced by SBCL 1.0.49.76. + (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) + (when (and s (fboundp s)) + (funcall s var)))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (sb-di:frame-code-location frame))) + (multiple-value-bind (vars more-context more-count) + (frame-debug-vars frame) + (let ((locals + (loop for v in vars + collect + (list :name (sb-di:debug-var-symbol v) + :id (sb-di:debug-var-id v) + :value (debug-var-value v frame loc))))) + (if (and more-context more-count) + (append locals + (list + (list :name + ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE + ;; specially. + (or (find-symbol "MORE" :sb-debug) 'more) + :id 0 + :value (multiple-value-list + (sb-c:%more-arg-values + more-context + 0 more-count))))) + locals))))) + +(defimplementation frame-var-value (frame var) + (let ((frame (nth-frame frame))) + (multiple-value-bind (vars more-context more-count) + (frame-debug-vars frame) + (let* ((loc (sb-di:frame-code-location frame)) + (dvar (if (= var (length vars)) + ;; If VAR is out of bounds, it must be the fake var + ;; we made up for &MORE. + (return-from frame-var-value + (multiple-value-list (sb-c:%more-arg-values + more-context + 0 more-count))) + (nth var vars)))) + (debug-var-value dvar frame loc))))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (sb-di:frame-catches (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (let ((frame (nth-frame index))) + (funcall (the function + (sb-di:preprocess-for-eval form + (sb-di:frame-code-location frame))) + frame))) + +(defimplementation frame-package (frame-number) + (let* ((frame (nth-frame frame-number)) + (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))) + (when fun + (let ((name (function-name fun))) + (typecase name + (null nil) + (symbol (symbol-package name)) + ((cons (eql setf) (cons symbol)) (symbol-package (cadr name)))))))) + +#+#.(slynk-sbcl::sbcl-with-restart-frame) +(progn + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index))) + (cond ((sb-debug:frame-has-debug-tag-p frame) + (let ((values (multiple-value-list (eval-in-frame form index)))) + (sb-debug:unwind-to-frame-and-call frame + (lambda () + (values-list values))))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (when (sb-debug:frame-has-debug-tag-p frame) + (multiple-value-bind (fname args) (sb-debug::frame-call frame) + (multiple-value-bind (fun arglist) + (if (and (sb-int:legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args) + (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) + (sb-debug::frame-args-as-list frame))) + (when (functionp fun) + (sb-debug:unwind-to-frame-and-call + frame + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist))))))) + (format nil "Cannot restart frame: ~S" frame)))) + +;; FIXME: this implementation doesn't unwind the stack before +;; re-invoking the function, but it's better than no implementation at +;; all. +#-#.(slynk-sbcl::sbcl-with-restart-frame) +(progn + (defun sb-debug-catch-tag-p (tag) + (and (symbolp tag) + (not (symbol-package tag)) + (string= tag :sb-debug-catch-tag))) + + (defimplementation return-from-frame (index form) + (let* ((frame (nth-frame index)) + (probe (assoc-if #'sb-debug-catch-tag-p + (sb-di::frame-catches frame)))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame))))) + + (defimplementation restart-frame (index) + (let ((frame (nth-frame index))) + (return-from-frame index (sb-debug::frame-call-as-list frame))))) + +;;;;; reference-conditions + +(defimplementation print-condition (condition stream) + (let ((sb-int:*print-condition-references* nil)) + (princ condition stream))) + + +;;;; Profiling + +(defimplementation profile (fname) + (when fname (eval `(sb-profile:profile ,fname)))) + +(defimplementation unprofile (fname) + (when fname (eval `(sb-profile:unprofile ,fname)))) + +(defimplementation unprofile-all () + (sb-profile:unprofile) + "All functions unprofiled.") + +(defimplementation profile-report () + (sb-profile:report)) + +(defimplementation profile-reset () + (sb-profile:reset) + "Reset profiling counters.") + +(defimplementation profiled-functions () + (sb-profile:profile)) + +(defimplementation profile-package (package callers methods) + (declare (ignore callers methods)) + (eval `(sb-profile:profile ,(package-name (find-package package))))) + + +;;;; Inspector + +(defmethod emacs-inspect ((o t)) + (cond ((sb-di::indirect-value-cell-p o) + (label-value-line* (:value (sb-kernel:value-cell-ref o)))) + (t + (multiple-value-bind (text label parts) (sb-impl::inspected-parts o) + (list* (string-right-trim '(#\Newline) text) + '(:newline) + (if label + (loop for (l . v) in parts + append (label-value-line l v)) + (loop for value in parts + for i from 0 + append (label-value-line i value)))))))) + +(defmethod emacs-inspect ((o function)) + (cond ((sb-kernel:simple-fun-p o) + (label-value-line* + (:name (sb-kernel:%simple-fun-name o)) + (:arglist (sb-kernel:%simple-fun-arglist o)) + (:type (sb-kernel:%simple-fun-type o)) + (:code (sb-kernel:fun-code-header o)) + (:documentation (documentation o t)))) + ((sb-kernel:closurep o) + (append + (label-value-line :function (sb-kernel:%closure-fun o)) + `("Closed over values:" (:newline)) + (loop for i below (1- (sb-kernel:get-closure-length o)) + append (label-value-line + i (sb-kernel:%closure-index-ref o i))))) + (t (call-next-method o)))) + +(defmethod emacs-inspect ((o sb-kernel:code-component)) + (append + (label-value-line* + (:code-size (sb-kernel:%code-code-size o)) + (:debug-info (sb-kernel:%code-debug-info o))) + `("Constants:" (:newline)) + (loop for i from sb-vm:code-constants-offset + below + (#.(slynk-backend:choose-symbol 'sb-kernel 'code-header-words + 'sb-kernel 'get-header-data) + o) + append (label-value-line i (sb-kernel:code-header-ref o i))) + `("Code:" (:newline) + ,(with-output-to-string (s) + (sb-disassem:disassemble-code-component o :stream s))))) + +(defmethod emacs-inspect ((o sb-ext:weak-pointer)) + (label-value-line* + (:value (sb-ext:weak-pointer-value o)))) + +(defmethod emacs-inspect ((o sb-kernel:fdefn)) + (label-value-line* + (:name (sb-kernel:fdefn-name o)) + (:function (sb-kernel:fdefn-fun o)))) + +(defmethod emacs-inspect :around ((o generic-function)) + (append + (call-next-method) + (label-value-line* + (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o)) + (:initial-methods (sb-pcl::generic-function-initial-methods o)) + ))) + + +;;;; Multiprocessing + +#+(and sb-thread + #.(slynk-backend:with-symbol "THREAD-NAME" "SB-THREAD")) +(progn + (defvar *thread-id-counter* 0) + + (defvar *thread-id-counter-lock* + (sb-thread:make-mutex :name "thread id counter lock")) + + (defun next-thread-id () + (sb-thread:with-mutex (*thread-id-counter-lock*) + (incf *thread-id-counter*))) + + (defvar *thread-id-map* (make-hash-table)) + + ;; This should be a thread -> id map but as weak keys are not + ;; supported it is id -> map instead. + (defvar *thread-id-map-lock* + (sb-thread:make-mutex :name "thread id map lock")) + + (defimplementation spawn (fn &key name) + (sb-thread:make-thread fn :name name)) + + (defimplementation thread-id (thread) + (block thread-id + (sb-thread:with-mutex (*thread-id-map-lock*) + (loop for id being the hash-key in *thread-id-map* + using (hash-value thread-pointer) + do + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (cond ((null maybe-thread) + ;; the value is gc'd, remove it manually + (remhash id *thread-id-map*)) + ((eq thread maybe-thread) + (return-from thread-id id))))) + ;; lazy numbering + (let ((id (next-thread-id))) + (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread)) + id)))) + + (defimplementation find-thread (id) + (sb-thread:with-mutex (*thread-id-map-lock*) + (let ((thread-pointer (gethash id *thread-id-map*))) + (if thread-pointer + (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer))) + (if maybe-thread + maybe-thread + ;; the value is gc'd, remove it manually + (progn + (remhash id *thread-id-map*) + nil))) + nil)))) + + (defimplementation thread-name (thread) + ;; sometimes the name is not a string (e.g. NIL) + (princ-to-string (sb-thread:thread-name thread))) + + (defimplementation thread-status (thread) + (if (sb-thread:thread-alive-p thread) + "Running" + "Stopped")) + + (defimplementation make-lock (&key name) + (sb-thread:make-mutex :name name)) + + (defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (sb-thread:with-recursive-lock (lock) (funcall function))) + + (defimplementation current-thread () + sb-thread:*current-thread*) + + (defimplementation all-threads () + (sb-thread:list-all-threads)) + + (defimplementation interrupt-thread (thread fn) + (sb-thread:interrupt-thread thread fn)) + + (defimplementation kill-thread (thread) + (sb-thread:terminate-thread thread)) + + (defimplementation thread-alive-p (thread) + (sb-thread:thread-alive-p thread)) + + (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock")) + (defvar *mailboxes* (list)) + (declaim (type list *mailboxes*)) + + (defstruct (mailbox (:conc-name mailbox.)) + thread + (mutex (sb-thread:make-mutex)) + (waitqueue (sb-thread:make-waitqueue)) + (queue '() :type list)) + + (defun mailbox (thread) + "Return THREAD's mailbox." + (sb-thread:with-mutex (*mailbox-lock*) + (or (find thread *mailboxes* :key #'mailbox.thread) + (let ((mb (make-mailbox :thread thread))) + (push mb *mailboxes*) + mb)))) + + (defimplementation wake-thread (thread) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-recursive-lock (mutex) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (mutex (mailbox.mutex mbox))) + (sb-thread:with-mutex (mutex) + (setf (mailbox.queue mbox) + (nconc (mailbox.queue mbox) (list message))) + (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))) + + (defimplementation receive-if (test &optional timeout) + (let* ((mbox (mailbox (current-thread))) + (mutex (mailbox.mutex mbox)) + (waitq (mailbox.waitqueue mbox))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (sb-thread:with-mutex (mutex) + (let* ((q (mailbox.queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))) + (when (eq timeout t) (return (values nil t))) + (sb-thread:condition-wait waitq mutex))))) + + (let ((alist '()) + (mutex (sb-thread:make-mutex :name "register-thread"))) + + (defimplementation register-thread (name thread) + (declare (type symbol name)) + (sb-thread:with-mutex (mutex) + (etypecase thread + (null + (setf alist (delete name alist :key #'car))) + (sb-thread:thread + (let ((probe (assoc name alist))) + (cond (probe (setf (cdr probe) thread)) + (t (setf alist (acons name thread alist)))))))) + nil) + + (defimplementation find-registered (name) + (sb-thread:with-mutex (mutex) + (cdr (assoc name alist)))))) + +(defimplementation quit-lisp () + #+#.(slynk-backend:with-symbol 'exit 'sb-ext) + (sb-ext:exit) + #-#.(slynk-backend:with-symbol 'exit 'sb-ext) + (progn + #+sb-thread + (dolist (thread (remove (current-thread) (all-threads))) + (ignore-errors (sb-thread:terminate-thread thread))) + (sb-ext:quit))) + + + +;;Trace implementations +;;In SBCL, we have: +;; (trace ) +;; (trace :methods ') ;to trace all methods of the gf +;; (trace (method ? (+))) +;; can be a normal name or a (setf name) + +(defun toggle-trace-aux (fspec &rest args) + (cond ((member fspec (eval '(trace)) :test #'equal) + (eval `(untrace ,fspec)) + (format nil "~S is now untraced." fspec)) + (t + (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args)) + (format nil "~S is now traced." fspec)))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) `(method ,@(rest fspec))) + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defmethod) + (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec))))) + ((:defgeneric) + (toggle-trace-aux (second spec) :methods t)) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux callee :wherein (list (process-fspec caller))))))) + +;;; Weak datastructures + +(defimplementation make-weak-key-hash-table (&rest args) + #+#.(slynk-sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :key args) + #-#.(slynk-sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation make-weak-value-hash-table (&rest args) + #+#.(slynk-sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table :weakness :value args) + #-#.(slynk-sbcl::sbcl-with-weak-hash-tables) + (apply #'make-hash-table args)) + +(defimplementation hash-table-weakness (hashtable) + #+#.(slynk-sbcl::sbcl-with-weak-hash-tables) + (sb-ext:hash-table-weakness hashtable)) + +;;; Floating point + +(defimplementation float-nan-p (float) + (sb-ext:float-nan-p float)) + +(defimplementation float-infinity-p (float) + (sb-ext:float-infinity-p float)) + +#-win32 +(defimplementation save-image (filename &optional restart-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (and (sb-posix:wifexited status) + (zerop (sb-posix:wexitstatus status)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (error "execv(3) returned."))) + (sb-alien:free-alien a-args)))) + + (defun runtime-pathname () + #+#.(slynk-backend:with-symbol + '*runtime-pathname* 'sb-ext) + sb-ext:*runtime-pathname* + #-#.(slynk-backend:with-symbol + '*runtime-pathname* 'sb-ext) + (car sb-ext:*posix-argv*)) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--slynk-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename (runtime-pathname)))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +#-win32 +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) + +(pushnew 'deinit-log-output sb-ext:*save-hooks*) + + +;;;; wrap interface implementation + +(defimplementation wrap (spec indicator &key before after replace) + (when (wrapped-p spec indicator) + (warn "~a already wrapped with indicator ~a, unwrapping first" + spec indicator) + (sb-int:unencapsulate spec indicator)) + (sb-int:encapsulate spec indicator + #-#.(slynk-backend:with-symbol 'arg-list 'sb-int) + (lambda (function &rest args) + (sbcl-wrap spec before after replace function args)) + #+#.(slynk-backend:with-symbol 'arg-list 'sb-int) + (if (sbcl-version>= 1 1 16) + (lambda () + (sbcl-wrap spec before after replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list))) + `(sbcl-wrap ',spec ,before ,after ,replace + (symbol-value 'sb-int:basic-definition) + (symbol-value 'sb-int:arg-list)))) + (symbol-function spec)) + +(defimplementation unwrap (spec indicator) + (sb-int:unencapsulate spec indicator)) + +(defimplementation wrapped-p (spec indicator) + (sb-int:encapsulated-p spec indicator)) + +(defun sbcl-wrap (spec before after replace function args) + (declare (ignore spec)) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list (if replace + (funcall replace + args) + (apply function args)))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed retlist :exited-non-locally)))))) + +#+#.(slynk-backend:with-symbol 'comma-expr 'sb-impl) +(progn + (defmethod sexp-in-bounds-p ((s sb-impl::comma) i) + (sexp-in-bounds-p (sb-impl::comma-expr s) i)) + + (defmethod sexp-ref ((s sb-impl::comma) i) + (sexp-ref (sb-impl::comma-expr s) i))) blob - /dev/null blob + c31106fe47b2d22fa433871893059b8ccf0f50b2 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/backend/scl.lisp @@ -0,0 +1,1726 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*- +;;; +;;; Scieneer Common Lisp code for SLY. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage slynk-scl + (:use cl slynk-backend slynk-source-path-parser slynk-source-file-cache)) + +(in-package slynk-scl) + + + +;;; slynk-mop + +(import-slynk-mop-symbols :clos '(:slot-definition-documentation)) + +(defun slynk-mop:slot-definition-documentation (slot) + (documentation slot t)) + + +;;;; TCP server +;;; +;;; SCL only supports the :spawn communication style. +;;; + +(defimplementation preferred-communication-style () + :spawn) + +(defimplementation create-socket (host port &key backlog) + (let ((addr (resolve-hostname host))) + (ext:create-inet-listener port :stream :host addr :reuse-address t + :backlog (or backlog 5)))) + +(defimplementation local-port (socket) + (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket)))) + +(defimplementation close-socket (socket) + (ext:close-socket (socket-fd socket))) + +(defimplementation accept-connection (socket + &key external-format buffering timeout) + (let ((buffering (or buffering :full)) + (fd (socket-fd socket))) + (loop + (let ((ready (sys:wait-until-fd-usable fd :input timeout))) + (unless ready + (error "Timeout accepting connection on socket: ~S~%" socket))) + (let ((new-fd (ignore-errors (ext:accept-tcp-connection fd)))) + (when new-fd + (return (make-socket-io-stream new-fd external-format + (ecase buffering + ((t) :full) + ((nil) :none) + (:line :line))))))))) + +(defimplementation set-stream-timeout (stream timeout) + (check-type timeout (or null real)) + (if (fboundp 'ext::stream-timeout) + (setf (ext::stream-timeout stream) timeout) + (setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout) + timeout))) + +;;;;; Sockets + +(defun socket-fd (socket) + "Return the file descriptor for the socket represented by 'socket." + (etypecase socket + (fixnum socket) + (stream (sys:fd-stream-fd socket)))) + +(defun resolve-hostname (hostname) + "Return the IP address of 'hostname as an integer (in host byte-order)." + (let ((hostent (ext:lookup-host-entry hostname))) + (car (ext:host-entry-addr-list hostent)))) + +(defvar *external-format-to-coding-system* + '((:iso-8859-1 + "latin-1" "latin-1-unix" "iso-latin-1-unix" + "iso-8859-1" "iso-8859-1-unix") + (:utf-8 "utf-8" "utf-8-unix") + (:euc-jp "euc-jp" "euc-jp-unix"))) + +(defimplementation find-external-format (coding-system) + (car (rassoc-if (lambda (x) (member coding-system x :test #'equal)) + *external-format-to-coding-system*))) + +(defun make-socket-io-stream (fd external-format buffering) + "Create a new input/output fd-stream for 'fd." + (cond ((not external-format) + (sys:make-fd-stream fd :input t :output t :buffering buffering + :element-type '(unsigned-byte 8))) + (t + (let* ((stream (sys:make-fd-stream fd :input t :output t + :element-type 'base-char + :buffering buffering + :external-format external-format))) + ;; Ignore character conversion errors. Without this the + ;; communication channel is prone to lockup if a character + ;; conversion error occurs. + (setf (lisp::character-conversion-stream-input-error-value stream) + #\?) + (setf (lisp::character-conversion-stream-output-error-value stream) + #\?) + stream)))) + + +;;;; Stream handling + +(defimplementation gray-package-name () + "EXT") + + +;;;; Compilation Commands + +(defvar *previous-compiler-condition* nil + "Used to detect duplicates.") + +(defvar *previous-context* nil + "Previous compiler error context.") + +(defvar *buffer-name* nil + "The name of the Emacs buffer we are compiling from. + Nil if we aren't compiling from a buffer.") + +(defvar *buffer-start-position* nil) +(defvar *buffer-substring* nil) + +(defimplementation call-with-compilation-hooks (function) + (let ((*previous-compiler-condition* nil) + (*previous-context* nil) + (*print-readably* nil)) + (handler-bind ((c::compiler-error #'handle-notification-condition) + (c::style-warning #'handle-notification-condition) + (c::warning #'handle-notification-condition)) + (funcall function)))) + +(defimplementation slynk-compile-file (input-file output-file + load-p external-format + &key policy) + (declare (ignore policy)) + (with-compilation-hooks () + (let ((*buffer-name* nil) + (ext:*ignore-extra-close-parentheses* nil)) + (multiple-value-bind (output-file warnings-p failure-p) + (compile-file input-file + :output-file output-file + :external-format external-format) + (values output-file warnings-p + (or failure-p + (when load-p + ;; Cache the latest source file for definition-finding. + (source-cache-get input-file + (file-write-date input-file)) + (not (load output-file))))))))) + +(defimplementation slynk-compile-string (string &key buffer position filename + line column policy) + (declare (ignore filename line column policy)) + (with-compilation-hooks () + (let ((*buffer-name* buffer) + (*buffer-start-position* position) + (*buffer-substring* string)) + (with-input-from-string (stream string) + (ext:compile-from-stream + stream + :source-info `(:emacs-buffer ,buffer + :emacs-buffer-offset ,position + :emacs-buffer-string ,string)))))) + + +;;;;; Trapping notes +;;; +;;; We intercept conditions from the compiler and resignal them as +;;; `slynk:compiler-condition's. + +(defun handle-notification-condition (condition) + "Handle a condition caused by a compiler warning." + (unless (eq condition *previous-compiler-condition*) + (let ((context (c::find-error-context nil))) + (setq *previous-compiler-condition* condition) + (setq *previous-context* context) + (signal-compiler-condition condition context)))) + +(defun signal-compiler-condition (condition context) + (signal 'compiler-condition + :original-condition condition + :severity (severity-for-emacs condition) + :message (brief-compiler-message-for-emacs condition) + :source-context (compiler-error-context context) + :location (if (read-error-p condition) + (read-error-location condition) + (compiler-note-location context)))) + +(defun severity-for-emacs (condition) + "Return the severity of 'condition." + (etypecase condition + ((satisfies read-error-p) :read-error) + (c::compiler-error :error) + (c::style-warning :note) + (c::warning :warning))) + +(defun read-error-p (condition) + (eq (type-of condition) 'c::compiler-read-error)) + +(defun brief-compiler-message-for-emacs (condition) + "Briefly describe a compiler error for Emacs. + When Emacs presents the message it already has the source popped up + and the source form highlighted. This makes much of the information in + the error-context redundant." + (princ-to-string condition)) + +(defun compiler-error-context (error-context) + "Describe a compiler error for Emacs including context information." + (declare (type (or c::compiler-error-context null) error-context)) + (multiple-value-bind (enclosing source) + (if error-context + (values (c::compiler-error-context-enclosing-source error-context) + (c::compiler-error-context-source error-context))) + (if (and enclosing source) + (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]" + enclosing source)))) + +(defun read-error-location (condition) + (let* ((finfo (car (c::source-info-current-file c::*source-info*))) + (file (c::file-info-name finfo)) + (pos (c::compiler-read-error-position condition))) + (cond ((and (eq file :stream) *buffer-name*) + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* pos))) + ((and (pathnamep file) (not *buffer-name*)) + (make-location (list :file (unix-truename file)) + (list :position (1+ pos)))) + (t (break))))) + +(defun compiler-note-location (context) + "Derive the location of a complier message from its context. + Return a `location' record, or (:error ) on failure." + (if (null context) + (note-error-location) + (let ((file (c::compiler-error-context-file-name context)) + (source (c::compiler-error-context-original-source context)) + (path + (reverse + (c::compiler-error-context-original-source-path context)))) + (or (locate-compiler-note file source path) + (note-error-location))))) + +(defun note-error-location () + "Pseudo-location for notes that can't be located." + (list :error "No error location available.")) + +(defun locate-compiler-note (file source source-path) + (cond ((and (eq file :stream) *buffer-name*) + ;; Compiling from a buffer + (make-location (list :buffer *buffer-name*) + (list :offset *buffer-start-position* + (source-path-string-position + source-path *buffer-substring*)))) + ((and (pathnamep file) (null *buffer-name*)) + ;; Compiling from a file + (make-location (list :file (unix-truename file)) + (list :position (1+ (source-path-file-position + source-path file))))) + ((and (eq file :lisp) (stringp source)) + ;; No location known, but we have the source form. + ;; XXX How is this case triggered? -luke (16/May/2004) + ;; This can happen if the compiler needs to expand a macro + ;; but the macro-expander is not yet compiled. Calling the + ;; (interpreted) macro-expander triggers IR1 conversion of + ;; the lambda expression for the expander and invokes the + ;; compiler recursively. + (make-location (list :source-form source) + (list :position 1))))) + +(defun unix-truename (pathname) + (ext:unix-namestring (truename pathname))) + + + +;;; TODO +(defimplementation who-calls (name) nil) +(defimplementation who-references (name) nil) +(defimplementation who-binds (name) nil) +(defimplementation who-sets (name) nil) +(defimplementation who-specializes (symbol) nil) +(defimplementation who-macroexpands (name) nil) + + +;;;; Find callers and callees +;;; +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call 'fn for each constant in 'code's constant pool." + (check-type code kernel:code-component) + (loop for i from vm:code-constants-offset below (kernel:get-header-data code) + do (funcall fn (kernel:code-header-ref code i)))) + +(defun function-callees (function) + "Return 'function's callees as a list of functions." + (let ((callees '())) + (map-code-constants + (vm::find-code-object function) + (lambda (obj) + (when (kernel:fdefn-p obj) + (push (kernel:fdefn-function obj) callees)))) + callees)) + +(declaim (ext:maybe-inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of 'spaces. FN + receives the object as argument. 'spaces should be a list of the + symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (declare (inline vm::map-allocated-objects) + (optimize (ext:inhibit-warnings 3))) + (vm::map-allocated-objects + (lambda (obj header size) + (declare (type fixnum size) (ignore size)) + (when (= vm:code-header-type header) + (funcall fn obj))) + space))) + +(declaim (ext:maybe-inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call 'fn for each code component with a fdefn for 'function in its + constant pool." + (let ((function (coerce function 'function))) + (declare (inline map-allocated-code-components)) + (map-allocated-code-components + spaces + (lambda (obj) + (map-code-constants + obj + (lambda (constant) + (when (and (kernel:fdefn-p constant) + (eq (kernel:fdefn-function constant) + function)) + (funcall fn obj)))))))) + +(defun function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return 'function's callers. The result is a list of code-objects." + (let ((referrers '())) + (declare (inline map-caller-code-components)) + (map-caller-code-components function spaces + (lambda (code) (push code referrers))) + referrers)) + +(defun debug-info-definitions (debug-info) + "Return the defintions for a debug-info. This should only be used + for code-object without entry points, i.e., byte compiled + code (are theree others?)" + ;; This mess has only been tested with #'ext::skip-whitespace, a + ;; byte-compiled caller of #'read-char . + (check-type debug-info (and (not c::compiled-debug-info) c::debug-info)) + (let ((name (c::debug-info-name debug-info)) + (source (c::debug-info-source debug-info))) + (destructuring-bind (first) source + (ecase (c::debug-source-from first) + (:file + (list (list name + (make-location + (list :file (unix-truename (c::debug-source-name first))) + (list :function-name (string name)))))))))) + +(defun valid-function-name-p (name) + (or (symbolp name) (and (consp name) + (eq (car name) 'setf) + (symbolp (cadr name)) + (not (cddr name))))) + +(defun code-component-entry-points (code) + "Return a list ((name location) ...) of function definitons for + the code omponent 'code." + (let ((names '())) + (do ((f (kernel:%code-entry-points code) (kernel::%function-next f))) + ((not f)) + (let ((name (kernel:%function-name f))) + (when (valid-function-name-p name) + (push (list name (function-location f)) names)))) + names)) + +(defimplementation list-callers (symbol) + "Return a list ((name location) ...) of callers." + (let ((components (function-callers symbol)) + (xrefs '())) + (dolist (code components) + (let* ((entry (kernel:%code-entry-points code)) + (defs (if entry + (code-component-entry-points code) + ;; byte compiled stuff + (debug-info-definitions + (kernel:%code-debug-info code))))) + (setq xrefs (nconc defs xrefs)))) + xrefs)) + +(defimplementation list-callees (symbol) + (let ((fns (function-callees symbol))) + (mapcar (lambda (fn) + (list (kernel:%function-name fn) + (function-location fn))) + fns))) + + +;;;; Resolving source locations +;;; +;;; Our mission here is to "resolve" references to code locations into +;;; actual file/buffer names and character positions. The references +;;; we work from come out of the compiler's statically-generated debug +;;; information, such as `code-location''s and `debug-source''s. For +;;; more details, see the "Debugger Programmer's Interface" section of +;;; the SCL manual. +;;; +;;; The first step is usually to find the corresponding "source-path" +;;; for the location. Once we have the source-path we can pull up the +;;; source file and `READ' our way through to the right position. The +;;; main source-code groveling work is done in +;;; `slynk-source-path-parser.lisp'. + +(defvar *debug-definition-finding* nil + "When true don't handle errors while looking for definitions. + This is useful when debugging the definition-finding code.") + +(defmacro safe-definition-finding (&body body) + "Execute 'body and return the source-location it returns. + If an error occurs and `*debug-definition-finding*' is false, then + return an error pseudo-location. + + The second return value is 'nil if no error occurs, otherwise it is the + condition object." + `(flet ((body () ,@body)) + (if *debug-definition-finding* + (body) + (handler-case (values (progn ,@body) nil) + (error (c) (values (list :error (princ-to-string c)) c)))))) + +(defun code-location-source-location (code-location) + "Safe wrapper around `code-location-from-source-location'." + (safe-definition-finding + (source-location-from-code-location code-location))) + +(defun source-location-from-code-location (code-location) + "Return the source location for 'code-location." + (let ((debug-fun (di:code-location-debug-function code-location))) + (when (di::bogus-debug-function-p debug-fun) + ;; Those lousy cheapskates! They've put in a bogus debug source + ;; because the code was compiled at a low debug setting. + (error "Bogus debug function: ~A" debug-fun))) + (let* ((debug-source (di:code-location-debug-source code-location)) + (from (di:debug-source-from debug-source)) + (name (di:debug-source-name debug-source))) + (ecase from + (:file + (location-in-file name code-location debug-source)) + (:stream + (location-in-stream code-location debug-source)) + (:lisp + ;; The location comes from a form passed to `compile'. + ;; The best we can do is return the form itself for printing. + (make-location + (list :source-form (with-output-to-string (*standard-output*) + (debug::print-code-location-source-form + code-location 100 t))) + (list :position 1)))))) + +(defun location-in-file (filename code-location debug-source) + "Resolve the source location for 'code-location in 'filename." + (let* ((code-date (di:debug-source-created debug-source)) + (source-code (get-source-code filename code-date))) + (with-input-from-string (s source-code) + (make-location (list :file (unix-truename filename)) + (list :position (1+ (code-location-stream-position + code-location s))) + `(:snippet ,(read-snippet s)))))) + +(defun location-in-stream (code-location debug-source) + "Resolve the source location for a 'code-location from a stream. + This only succeeds if the code was compiled from an Emacs buffer." + (unless (debug-source-info-from-emacs-buffer-p debug-source) + (error "The code is compiled from a non-SLY stream.")) + (let* ((info (c::debug-source-info debug-source)) + (string (getf info :emacs-buffer-string)) + (position (code-location-string-offset + code-location + string))) + (make-location + (list :buffer (getf info :emacs-buffer)) + (list :offset (getf info :emacs-buffer-offset) position) + (list :snippet (with-input-from-string (s string) + (file-position s position) + (read-snippet s)))))) + +;;;;; Function-name locations +;;; +(defun debug-info-function-name-location (debug-info) + "Return a function-name source-location for 'debug-info. + Function-name source-locations are a fallback for when precise + positions aren't available." + (with-struct (c::debug-info- (fname name) source) debug-info + (with-struct (c::debug-source- info from name) (car source) + (ecase from + (:file + (make-location (list :file (namestring (truename name))) + (list :function-name (string fname)))) + (:stream + (assert (debug-source-info-from-emacs-buffer-p (car source))) + (make-location (list :buffer (getf info :emacs-buffer)) + (list :function-name (string fname)))) + (:lisp + (make-location (list :source-form (princ-to-string (aref name 0))) + (list :position 1))))))) + +(defun debug-source-info-from-emacs-buffer-p (debug-source) + "Does the `info' slot of 'debug-source contain an Emacs buffer location? + This is true for functions that were compiled directly from buffers." + (info-from-emacs-buffer-p (c::debug-source-info debug-source))) + +(defun info-from-emacs-buffer-p (info) + (and info + (consp info) + (eq :emacs-buffer (car info)))) + + +;;;;; Groveling source-code for positions + +(defun code-location-stream-position (code-location stream) + "Return the byte offset of 'code-location in 'stream. Extract the + toplevel-form-number and form-number from 'code-location and use that + to find the position of the corresponding form. + + Finish with 'stream positioned at the start of the code location." + (let* ((location (debug::maybe-block-start-location code-location)) + (tlf-offset (di:code-location-top-level-form-offset location)) + (form-number (di:code-location-form-number location))) + (let ((pos (form-number-stream-position tlf-offset form-number stream))) + (file-position stream pos) + pos))) + +(defun form-number-stream-position (tlf-number form-number stream) + "Return the starting character position of a form in 'stream. + 'tlf-number is the top-level-form number. + 'form-number is an index into a source-path table for the TLF." + (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream) + (let* ((path-table (di:form-number-translations tlf 0)) + (source-path + (if (<= (length path-table) form-number) ; source out of sync? + (list 0) ; should probably signal a condition + (reverse (cdr (aref path-table form-number)))))) + (source-path-source-position source-path tlf position-map)))) + +(defun code-location-string-offset (code-location string) + "Return the byte offset of 'code-location in 'string. + See 'code-location-stream-position." + (with-input-from-string (s string) + (code-location-stream-position code-location s))) + + +;;;; Finding definitions + +;;; There are a great many different types of definition for us to +;;; find. We search for definitions of every kind and return them in a +;;; list. + +(defimplementation find-definitions (name) + (append (function-definitions name) + (setf-definitions name) + (variable-definitions name) + (class-definitions name) + (type-definitions name) + (compiler-macro-definitions name) + (source-transform-definitions name) + (function-info-definitions name) + (ir1-translator-definitions name))) + +;;;;; Functions, macros, generic functions, methods +;;; +;;; We make extensive use of the compile-time debug information that +;;; SCL records, in particular "debug functions" and "code +;;; locations." Refer to the "Debugger Programmer's Interface" section +;;; of the SCL manual for more details. + +(defun function-definitions (name) + "Return definitions for 'name in the \"function namespace\", i.e., + regular functions, generic functions, methods and macros. + 'name can any valid function name (e.g, (setf car))." + (let ((macro? (and (symbolp name) (macro-function name))) + (special? (and (symbolp name) (special-operator-p name))) + (function? (and (valid-function-name-p name) + (ext:info :function :definition name) + (if (symbolp name) (fboundp name) t)))) + (cond (macro? + (list `((defmacro ,name) + ,(function-location (macro-function name))))) + (special? + (list `((:special-operator ,name) + (:error ,(format nil "Special operator: ~S" name))))) + (function? + (let ((function (fdefinition name))) + (if (genericp function) + (generic-function-definitions name function) + (list (list `(function ,name) + (function-location function))))))))) + +;;;;;; Ordinary (non-generic/macro/special) functions +;;; +;;; First we test if FUNCTION is a closure created by defstruct, and +;;; if so extract the defstruct-description (`dd') from the closure +;;; and find the constructor for the struct. Defstruct creates a +;;; defun for the default constructor and we use that as an +;;; approximation to the source location of the defstruct. +;;; +;;; For an ordinary function we return the source location of the +;;; first code-location we find. +;;; +(defun function-location (function) + "Return the source location for FUNCTION." + (cond ((struct-closure-p function) + (struct-closure-location function)) + ((c::byte-function-or-closure-p function) + (byte-function-location function)) + (t + (compiled-function-location function)))) + +(defun compiled-function-location (function) + "Return the location of a regular compiled function." + (multiple-value-bind (code-location error) + (safe-definition-finding (function-first-code-location function)) + (cond (error (list :error (princ-to-string error))) + (t (code-location-source-location code-location))))) + +(defun function-first-code-location (function) + "Return the first code-location we can find for 'function." + (and (function-has-debug-function-p function) + (di:debug-function-start-location + (di:function-debug-function function)))) + +(defun function-has-debug-function-p (function) + (di:function-debug-function function)) + +(defun function-code-object= (closure function) + (and (eq (vm::find-code-object closure) + (vm::find-code-object function)) + (not (eq closure function)))) + + +(defun byte-function-location (fn) + "Return the location of the byte-compiled function 'fn." + (etypecase fn + ((or c::hairy-byte-function c::simple-byte-function) + (let* ((component (c::byte-function-component fn)) + (debug-info (kernel:%code-debug-info component))) + (debug-info-function-name-location debug-info))) + (c::byte-closure + (byte-function-location (c::byte-closure-function fn))))) + +;;; Here we deal with structure accessors. Note that `dd' is a +;;; "defstruct descriptor" structure in SCL. A `dd' describes a +;;; `defstruct''d structure. + +(defun struct-closure-p (function) + "Is 'function a closure created by defstruct?" + (or (function-code-object= function #'kernel::structure-slot-accessor) + (function-code-object= function #'kernel::structure-slot-setter) + (function-code-object= function #'kernel::%defstruct))) + +(defun struct-closure-location (function) + "Return the location of the structure that 'function belongs to." + (assert (struct-closure-p function)) + (safe-definition-finding + (dd-location (struct-closure-dd function)))) + +(defun struct-closure-dd (function) + "Return the defstruct-definition (dd) of FUNCTION." + (assert (= (kernel:get-type function) vm:closure-header-type)) + (flet ((find-layout (function) + (sys:find-if-in-closure + (lambda (x) + (let ((value (if (di::indirect-value-cell-p x) + (c:value-cell-ref x) + x))) + (when (kernel::layout-p value) + (return-from find-layout value)))) + function))) + (kernel:layout-info (find-layout function)))) + +(defun dd-location (dd) + "Return the location of a `defstruct'." + ;; Find the location in a constructor. + (function-location (struct-constructor dd))) + +(defun struct-constructor (dd) + "Return a constructor function from a defstruct definition. +Signal an error if no constructor can be found." + (let ((constructor (or (kernel:dd-default-constructor dd) + (car (kernel::dd-constructors dd))))) + (when (or (null constructor) + (and (consp constructor) (null (car constructor)))) + (error "Cannot find structure's constructor: ~S" + (kernel::dd-name dd))) + (coerce (if (consp constructor) (first constructor) constructor) + 'function))) + +;;;;;; Generic functions and methods + +(defun generic-function-definitions (name function) + "Return the definitions of a generic function and its methods." + (cons (list `(defgeneric ,name) (gf-location function)) + (gf-method-definitions function))) + +(defun gf-location (gf) + "Return the location of the generic function GF." + (definition-source-location gf (clos:generic-function-name gf))) + +(defun gf-method-definitions (gf) + "Return the locations of all methods of the generic function GF." + (mapcar #'method-definition (clos:generic-function-methods gf))) + +(defun method-definition (method) + (list (method-dspec method) + (method-location method))) + +(defun method-dspec (method) + "Return a human-readable \"definition specifier\" for METHOD." + (let* ((gf (clos:method-generic-function method)) + (name (clos:generic-function-name gf)) + (specializers (clos:method-specializers method)) + (qualifiers (clos:method-qualifiers method))) + `(method ,name ,@qualifiers ,specializers + #+nil (clos::unparse-specializers specializers)))) + +;; XXX maybe special case setters/getters +(defun method-location (method) + (function-location (clos:method-function method))) + +(defun genericp (fn) + (typep fn 'generic-function)) + +;;;;;; Types and classes + +(defun type-definitions (name) + "Return `deftype' locations for type NAME." + (maybe-make-definition (ext:info :type :expander name) 'deftype name)) + +(defun maybe-make-definition (function kind name) + "If FUNCTION is non-nil then return its definition location." + (if function + (list (list `(,kind ,name) (function-location function))))) + +(defun class-definitions (name) + "Return the definition locations for the class called NAME." + (if (symbolp name) + (let ((class (find-class name nil))) + (etypecase class + (null '()) + (structure-class + (list (list `(defstruct ,name) + (dd-location (find-dd name))))) + (standard-class + (list (list `(defclass ,name) + (class-location (find-class name))))) + ((or built-in-class + kernel:funcallable-structure-class) + (list (list `(kernel::define-type-class ,name) + `(:error + ,(format nil "No source info for ~A" name))))))))) + +(defun class-location (class) + "Return the `defclass' location for CLASS." + (definition-source-location class (class-name class))) + +(defun find-dd (name) + "Find the defstruct-definition by the name of its structure-class." + (let ((layout (ext:info :type :compiler-layout name))) + (if layout + (kernel:layout-info layout)))) + +(defun condition-class-location (class) + (let ((name (class-name class))) + `(:error ,(format nil "No location info for condition: ~A" name)))) + +(defun make-name-in-file-location (file string) + (multiple-value-bind (filename c) + (ignore-errors + (unix-truename (merge-pathnames (make-pathname :type "lisp") + file))) + (cond (filename (make-location `(:file ,filename) + `(:function-name ,(string string)))) + (t (list :error (princ-to-string c)))))) + +(defun definition-source-location (object name) + `(:error ,(format nil "No source info for: ~A" object))) + +(defun setf-definitions (name) + (let ((function (or (ext:info :setf :inverse name) + (ext:info :setf :expander name)))) + (if function + (list (list `(setf ,name) + (function-location (coerce function 'function))))))) + + +(defun variable-location (symbol) + `(:error ,(format nil "No source info for variable ~S" symbol))) + +(defun variable-definitions (name) + (if (symbolp name) + (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name) + (if recorded-p + (list (list `(variable ,kind ,name) + (variable-location name))))))) + +(defun compiler-macro-definitions (symbol) + (maybe-make-definition (compiler-macro-function symbol) + 'define-compiler-macro + symbol)) + +(defun source-transform-definitions (name) + (maybe-make-definition (ext:info :function :source-transform name) + 'c:def-source-transform + name)) + +(defun function-info-definitions (name) + (let ((info (ext:info :function :info name))) + (if info + (append (loop for transform in (c::function-info-transforms info) + collect (list `(c:deftransform ,name + ,(c::type-specifier + (c::transform-type transform))) + (function-location (c::transform-function + transform)))) + (maybe-make-definition (c::function-info-derive-type info) + 'c::derive-type name) + (maybe-make-definition (c::function-info-optimizer info) + 'c::optimizer name) + (maybe-make-definition (c::function-info-ltn-annotate info) + 'c::ltn-annotate name) + (maybe-make-definition (c::function-info-ir2-convert info) + 'c::ir2-convert name) + (loop for template in (c::function-info-templates info) + collect (list `(c::vop ,(c::template-name template)) + (function-location + (c::vop-info-generator-function + template)))))))) + +(defun ir1-translator-definitions (name) + (maybe-make-definition (ext:info :function :ir1-convert name) + 'c:def-ir1-translator name)) + + +;;;; Documentation. + +(defimplementation describe-symbol-for-emacs (symbol) + (let ((result '())) + (flet ((doc (kind) + (or (documentation symbol kind) :not-documented)) + (maybe-push (property value) + (when value + (setf result (list* property value result))))) + (maybe-push + :variable (multiple-value-bind (kind recorded-p) + (ext:info variable kind symbol) + (declare (ignore kind)) + (if (or (boundp symbol) recorded-p) + (doc 'variable)))) + (when (fboundp symbol) + (maybe-push + (cond ((macro-function symbol) :macro) + ((special-operator-p symbol) :special-operator) + ((genericp (fdefinition symbol)) :generic-function) + (t :function)) + (doc 'function))) + (maybe-push + :setf (if (or (ext:info setf inverse symbol) + (ext:info setf expander symbol)) + (doc 'setf))) + (maybe-push + :type (if (ext:info type kind symbol) + (doc 'type))) + (maybe-push + :class (if (find-class symbol nil) + (doc 'class))) + (maybe-push + :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown)) + (doc 'alien-type))) + (maybe-push + :alien-struct (if (ext:info alien-type struct symbol) + (doc nil))) + (maybe-push + :alien-union (if (ext:info alien-type union symbol) + (doc nil))) + (maybe-push + :alien-enum (if (ext:info alien-type enum symbol) + (doc nil))) + result))) + +(defimplementation describe-definition (symbol namespace) + (describe (ecase namespace + (:variable + symbol) + ((:function :generic-function) + (symbol-function symbol)) + (:setf + (or (ext:info setf inverse symbol) + (ext:info setf expander symbol))) + (:type + (kernel:values-specifier-type symbol)) + (:class + (find-class symbol)) + (:alien-struct + (ext:info :alien-type :struct symbol)) + (:alien-union + (ext:info :alien-type :union symbol)) + (:alien-enum + (ext:info :alien-type :enum symbol)) + (:alien-type + (ecase (ext:info :alien-type :kind symbol) + (:primitive + (let ((alien::*values-type-okay* t)) + (funcall (ext:info :alien-type :translator symbol) + (list symbol)))) + ((:defined) + (ext:info :alien-type :definition symbol)) + (:unknown :unknown)))))) + +;;;;; Argument lists + +(defimplementation arglist (fun) + (multiple-value-bind (args winp) + (ext:function-arglist fun) + (if winp args :not-available))) + +(defimplementation function-name (function) + (cond ((eval:interpreted-function-p function) + (eval:interpreted-function-name function)) + ((typep function 'generic-function) + (clos:generic-function-name function)) + ((c::byte-function-or-closure-p function) + (c::byte-function-name function)) + (t (kernel:%function-name (kernel:%function-self function))))) + + +;;; A harder case: an approximate arglist is derived from available +;;; debugging information. + +(defun debug-function-arglist (debug-function) + "Derive the argument list of DEBUG-FUNCTION from debug info." + (let ((args (di::debug-function-lambda-list debug-function)) + (required '()) + (optional '()) + (rest '()) + (key '())) + ;; collect the names of debug-vars + (dolist (arg args) + (etypecase arg + (di::debug-variable + (push (di::debug-variable-symbol arg) required)) + ((member :deleted) + (push ':deleted required)) + (cons + (ecase (car arg) + (:keyword + (push (second arg) key)) + (:optional + (push (debug-variable-symbol-or-deleted (second arg)) optional)) + (:rest + (push (debug-variable-symbol-or-deleted (second arg)) rest)))))) + ;; intersperse lambda keywords as needed + (append (nreverse required) + (if optional (cons '&optional (nreverse optional))) + (if rest (cons '&rest (nreverse rest))) + (if key (cons '&key (nreverse key)))))) + +(defun debug-variable-symbol-or-deleted (var) + (etypecase var + (di:debug-variable + (di::debug-variable-symbol var)) + ((member :deleted) + '#:deleted))) + +(defun symbol-debug-function-arglist (fname) + "Return FNAME's debug-function-arglist and %function-arglist. + A utility for debugging DEBUG-FUNCTION-ARGLIST." + (let ((fn (fdefinition fname))) + (values (debug-function-arglist (di::function-debug-function fn)) + (kernel:%function-arglist (kernel:%function-self fn))))) + + +;;;; Miscellaneous. + +(defimplementation macroexpand-all (form &optional env) + (declare (ignore env)) + (macroexpand form)) + +(defimplementation set-default-directory (directory) + (setf (ext:default-directory) (namestring directory)) + ;; Setting *default-pathname-defaults* to an absolute directory + ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive. + (setf *default-pathname-defaults* (pathname (ext:default-directory))) + (default-directory)) + +(defimplementation default-directory () + (namestring (ext:default-directory))) + +(defimplementation pathname-to-filename (pathname) + (ext:unix-namestring pathname nil)) + +(defimplementation getpid () + (unix:unix-getpid)) + +(defimplementation lisp-implementation-type-name () + (if (eq ext:*case-mode* :upper) "scl" "scl-lower")) + +(defimplementation quit-lisp () + (ext:quit)) + +;;; source-path-{stream,file,string,etc}-position moved into +;;; slynk-source-path-parser + + +;;;; Debugging + +(defvar *sly-db-stack-top*) + +(defimplementation call-with-debugging-environment (debugger-loop-fn) + (let* ((*sly-db-stack-top* (or debug:*stack-top-hint* (di:top-frame))) + (debug:*stack-top-hint* nil) + (kernel:*current-level* 0)) + (handler-bind ((di::unhandled-condition + (lambda (condition) + (error 'sly-db-condition + :original-condition condition)))) + (funcall debugger-loop-fn)))) + +(defun frame-down (frame) + (handler-case (di:frame-down frame) + (di:no-debug-info () nil))) + +(defun nth-frame (index) + (do ((frame *sly-db-stack-top* (frame-down frame)) + (i index (1- i))) + ((zerop i) frame))) + +(defimplementation compute-backtrace (start end) + (let ((end (or end most-positive-fixnum))) + (loop for f = (nth-frame start) then (frame-down f) + for i from start below end + while f collect f))) + +(defimplementation print-frame (frame stream) + (let ((*standard-output* stream)) + (handler-case + (debug::print-frame-call frame :verbosity 1 :number nil) + (error (e) + (ignore-errors (princ e stream)))))) + +(defimplementation frame-source-location (index) + (code-location-source-location (di:frame-code-location (nth-frame index)))) + +(defimplementation eval-in-frame (form index) + (di:eval-in-frame (nth-frame index) form)) + +(defun frame-debug-vars (frame) + "Return a vector of debug-variables in frame." + (di::debug-function-debug-variables (di:frame-debug-function frame))) + +(defun debug-var-value (var frame location) + (let ((validity (di:debug-variable-validity var location))) + (ecase validity + (:valid (di:debug-variable-value var frame)) + ((:invalid :unknown) (make-symbol (string validity)))))) + +(defimplementation frame-locals (index) + (let* ((frame (nth-frame index)) + (loc (di:frame-code-location frame)) + (vars (frame-debug-vars frame))) + (loop for v across vars collect + (list :name (di:debug-variable-symbol v) + :id (di:debug-variable-id v) + :value (debug-var-value v frame loc))))) + +(defimplementation frame-var-value (frame var) + (let* ((frame (nth-frame frame)) + (dvar (aref (frame-debug-vars frame) var))) + (debug-var-value dvar frame (di:frame-code-location frame)))) + +(defimplementation frame-catch-tags (index) + (mapcar #'car (di:frame-catches (nth-frame index)))) + +(defimplementation return-from-frame (index form) + (let ((sym (find-symbol (symbol-name '#:find-debug-tag-for-frame) + :debug-internals))) + (if sym + (let* ((frame (nth-frame index)) + (probe (funcall sym frame))) + (cond (probe (throw (car probe) (eval-in-frame form index))) + (t (format nil "Cannot return from frame: ~S" frame)))) + "return-from-frame is not implemented in this version of SCL."))) + +(defimplementation activate-stepping (frame) + (set-step-breakpoints (nth-frame frame))) + +(defimplementation sly-db-break-on-return (frame) + (break-on-return (nth-frame frame))) + +;;; We set the breakpoint in the caller which might be a bit confusing. +;;; +(defun break-on-return (frame) + (let* ((caller (di:frame-down frame)) + (cl (di:frame-code-location caller))) + (flet ((hook (frame bp) + (when (frame-pointer= frame caller) + (di:delete-breakpoint bp) + (signal-breakpoint bp frame)))) + (let* ((info (ecase (di:code-location-kind cl) + ((:single-value-return :unknown-return) nil) + (:known-return (debug-function-returns + (di:frame-debug-function frame))))) + (bp (di:make-breakpoint #'hook cl :kind :code-location + :info info))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~A" caller)))))) + +(defun frame-pointer= (frame1 frame2) + "Return true if the frame pointers of FRAME1 and FRAME2 are the same." + (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2))) + +;;; The PC in escaped frames at a single-return-value point is +;;; actually vm:single-value-return-byte-offset bytes after the +;;; position given in the debug info. Here we try to recognize such +;;; cases. +;;; +(defun next-code-locations (frame code-location) + "Like `debug::next-code-locations' but be careful in escaped frames." + (let ((next (debug::next-code-locations code-location))) + (flet ((adjust-pc () + (let ((cl (di::copy-compiled-code-location code-location))) + (incf (di::compiled-code-location-pc cl) + vm:single-value-return-byte-offset) + cl))) + (cond ((and (di::compiled-frame-escaped frame) + (eq (di:code-location-kind code-location) + :single-value-return) + (= (length next) 1) + (di:code-location= (car next) (adjust-pc))) + (debug::next-code-locations (car next))) + (t + next))))) + +(defun set-step-breakpoints (frame) + (let ((cl (di:frame-code-location frame))) + (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl)) + (error "Cannot step in elsewhere code")) + (let* ((debug::*bad-code-location-types* + (remove :call-site debug::*bad-code-location-types*)) + (next (next-code-locations frame cl))) + (cond (next + (let ((steppoints '())) + (flet ((hook (bp-frame bp) + (signal-breakpoint bp bp-frame) + (mapc #'di:delete-breakpoint steppoints))) + (dolist (code-location next) + (let ((bp (di:make-breakpoint #'hook code-location + :kind :code-location))) + (di:activate-breakpoint bp) + (push bp steppoints)))))) + (t + (break-on-return frame)))))) + + +;; XXX the return values at return breakpoints should be passed to the +;; user hooks. debug-int.lisp should be changed to do this cleanly. + +;;; The sigcontext and the PC for a breakpoint invocation are not +;;; passed to user hook functions, but we need them to extract return +;;; values. So we advice di::handle-breakpoint and bind the values to +;;; special variables. +;;; +(defvar *breakpoint-sigcontext*) +(defvar *breakpoint-pc*) + +(defun sigcontext-object (sc index) + "Extract the lisp object in sigcontext SC at offset INDEX." + (kernel:make-lisp-obj (vm:ucontext-register sc index))) + +(defun known-return-point-values (sigcontext sc-offsets) + (let ((fp (system:int-sap (vm:ucontext-register sigcontext + vm::cfp-offset)))) + (system:without-gcing + (loop for sc-offset across sc-offsets + collect (di::sub-access-debug-var-slot fp sc-offset sigcontext))))) + +;;; SCL returns the first few values in registers and the rest on +;;; the stack. In the multiple value case, the number of values is +;;; stored in a dedicated register. The values of the registers can be +;;; accessed in the sigcontext for the breakpoint. There are 3 kinds +;;; of return conventions: :single-value-return, :unknown-return, and +;;; :known-return. +;;; +;;; The :single-value-return convention returns the value in a +;;; register without setting the nargs registers. +;;; +;;; The :unknown-return variant is used for multiple values. A +;;; :unknown-return point consists actually of 2 breakpoints: one for +;;; the single value case and one for the general case. The single +;;; value breakpoint comes vm:single-value-return-byte-offset after +;;; the multiple value breakpoint. +;;; +;;; The :known-return convention is used by local functions. +;;; :known-return is currently not supported because we don't know +;;; where the values are passed. +;;; +(defun breakpoint-values (breakpoint) + "Return the list of return values for a return point." + (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets)))) + (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3))) + (alien:sap-alien *breakpoint-sigcontext* (* unix:ucontext)))) + (cl (di:breakpoint-what breakpoint))) + (ecase (di:code-location-kind cl) + (:single-value-return + (list (1st sc))) + (:known-return + (let ((info (di:breakpoint-info breakpoint))) + (if (vectorp info) + (known-return-point-values sc info) + (progn + ;;(break) + (list "<>" info))))) + (:unknown-return + (let ((mv-return-pc (di::compiled-code-location-pc cl))) + (if (= mv-return-pc *breakpoint-pc*) + (mv-function-end-breakpoint-values sc) + (list (1st sc))))))))) + +(defun mv-function-end-breakpoint-values (sigcontext) + (let ((sym (find-symbol + (symbol-name '#:function-end-breakpoint-values/standard) + :debug-internals))) + (cond (sym (funcall sym sigcontext)) + (t (di::get-function-end-breakpoint-values sigcontext))))) + +(defun debug-function-returns (debug-fun) + "Return the return style of DEBUG-FUN." + (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun))) + (c::compiled-debug-function-returns cdfun))) + +(define-condition breakpoint (simple-condition) + ((message :initarg :message :reader breakpoint.message) + (values :initarg :values :reader breakpoint.values)) + (:report (lambda (c stream) (princ (breakpoint.message c) stream)))) + +#+nil +(defimplementation condition-extras ((c breakpoint)) + ;; simply pop up the source buffer + `((:short-frame-source 0))) + +(defun signal-breakpoint (breakpoint frame) + "Signal a breakpoint condition for BREAKPOINT in FRAME. +Try to create a informative message." + (flet ((brk (values fstring &rest args) + (let ((msg (apply #'format nil fstring args)) + (debug:*stack-top-hint* frame)) + (break 'breakpoint :message msg :values values)))) + (with-struct (di::breakpoint- kind what) breakpoint + (case kind + (:code-location + (case (di:code-location-kind what) + ((:single-value-return :known-return :unknown-return) + (let ((values (breakpoint-values breakpoint))) + (brk values "Return value: ~{~S ~}" values))) + (t + #+(or) + (when (eq (di:code-location-kind what) :call-site) + (call-site-function breakpoint frame)) + (brk nil "Breakpoint: ~S ~S" + (di:code-location-kind what) + (di::compiled-code-location-pc what))))) + (:function-start + (brk nil "Function start breakpoint")) + (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame)))))) + +#+nil +(defimplementation sly-db-break-at-start (fname) + (let ((debug-fun (di:function-debug-function (coerce fname 'function)))) + (cond ((not debug-fun) + `(:error ,(format nil "~S has no debug-function" fname))) + (t + (flet ((hook (frame bp &optional args cookie) + (declare (ignore args cookie)) + (signal-breakpoint bp frame))) + (let ((bp (di:make-breakpoint #'hook debug-fun + :kind :function-start))) + (di:activate-breakpoint bp) + `(:ok ,(format nil "Set breakpoint in ~S" fname)))))))) + +(defun frame-cfp (frame) + "Return the Control-Stack-Frame-Pointer for FRAME." + (etypecase frame + (di::compiled-frame (di::frame-pointer frame)) + ((or di::interpreted-frame null) -1))) + +(defun frame-ip (frame) + "Return the (absolute) instruction pointer and the relative pc of FRAME." + (if (not frame) + -1 + (let ((debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((code-loc (di:frame-code-location frame)) + (component (di::compiled-debug-function-component debug-fun)) + (pc (di::compiled-code-location-pc code-loc)) + (ip (sys:without-gcing + (sys:sap-int + (sys:sap+ (kernel:code-instructions component) pc))))) + (values ip pc))) + ((or di::bogus-debug-function di::interpreted-debug-function) + -1))))) + +(defun frame-registers (frame) + "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER." + (let* ((cfp (frame-cfp frame)) + (csp (frame-cfp (di::frame-up frame))) + (ip (frame-ip frame)) + (ocfp (frame-cfp (di::frame-down frame))) + (lra (frame-ip (di::frame-down frame)))) + (values csp cfp ip ocfp lra))) + +(defun print-frame-registers (frame-number) + (let ((frame (di::frame-real-frame (nth-frame frame-number)))) + (flet ((fixnum (p) (etypecase p + (integer p) + (sys:system-area-pointer (sys:sap-int p))))) + (apply #'format t "~ +CSP = ~X +CFP = ~X +IP = ~X +OCFP = ~X +LRA = ~X~%" (mapcar #'fixnum + (multiple-value-list (frame-registers frame))))))) + + +(defimplementation disassemble-frame (frame-number) + "Return a string with the disassembly of frames code." + (print-frame-registers frame-number) + (terpri) + (let* ((frame (di::frame-real-frame (nth-frame frame-number))) + (debug-fun (di::frame-debug-function frame))) + (etypecase debug-fun + (di::compiled-debug-function + (let* ((component (di::compiled-debug-function-component debug-fun)) + (fun (di:debug-function-function debug-fun))) + (if fun + (disassemble fun) + (disassem:disassemble-code-component component)))) + (di::bogus-debug-function + (format t "~%[Disassembling bogus frames not implemented]"))))) + + +;;;; Inspecting + +(defconstant +lowtag-symbols+ + '(vm:even-fixnum-type + vm:instance-pointer-type + vm:other-immediate-0-type + vm:list-pointer-type + vm:odd-fixnum-type + vm:function-pointer-type + vm:other-immediate-1-type + vm:other-pointer-type) + "Names of the constants that specify type tags. +The `symbol-value' of each element is a type tag.") + +(defconstant +header-type-symbols+ + (labels ((suffixp (suffix string) + (and (>= (length string) (length suffix)) + (string= string suffix :start1 (- (length string) + (length suffix))))) + (header-type-symbol-p (x) + (and (suffixp (symbol-name '#:-type) (symbol-name x)) + (not (member x +lowtag-symbols+)) + (boundp x) + (typep (symbol-value x) 'fixnum)))) + (remove-if-not #'header-type-symbol-p + (append (apropos-list (symbol-name '#:-type) :vm) + (apropos-list (symbol-name '#:-type) :bignum)))) + "A list of names of the type codes in boxed objects.") + +(defimplementation describe-primitive-type (object) + (with-output-to-string (*standard-output*) + (let* ((lowtag (kernel:get-lowtag object)) + (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value))) + (format t "lowtag: ~A" lowtag-symbol) + (when (member lowtag (list vm:other-pointer-type + vm:function-pointer-type + vm:other-immediate-0-type + vm:other-immediate-1-type + )) + (let* ((type (kernel:get-type object)) + (type-symbol (find type +header-type-symbols+ + :key #'symbol-value))) + (format t ", type: ~A" type-symbol)))))) + +(defmethod emacs-inspect ((o t)) + (cond ((di::indirect-value-cell-p o) + `("Value: " (:value ,(c:value-cell-ref o)))) + ((alien::alien-value-p o) + (inspect-alien-value o)) + (t + (scl-inspect o)))) + +(defun scl-inspect (o) + (destructuring-bind (text labeledp . parts) + (inspect::describe-parts o) + (list* (format nil "~A~%" text) + (if labeledp + (loop for (label . value) in parts + append (label-value-line label value)) + (loop for value in parts for i from 0 + append (label-value-line i value)))))) + +(defmethod emacs-inspect ((o function)) + (let ((header (kernel:get-type o))) + (cond ((= header vm:function-header-type) + (list* (format nil "~A is a function.~%" o) + (append (label-value-line* + ("Self" (kernel:%function-self o)) + ("Next" (kernel:%function-next o)) + ("Name" (kernel:%function-name o)) + ("Arglist" (kernel:%function-arglist o)) + ("Type" (kernel:%function-type o)) + ("Code" (kernel:function-code-header o))) + (list + (with-output-to-string (s) + (disassem:disassemble-function o :stream s)))))) + ((= header vm:closure-header-type) + (list* (format nil "~A is a closure.~%" o) + (append + (label-value-line "Function" (kernel:%closure-function o)) + `("Environment:" (:newline)) + (loop for i from 0 below (- (kernel:get-closure-length o) + (1- vm:closure-info-offset)) + append (label-value-line + i (kernel:%closure-index-ref o i)))))) + ((eval::interpreted-function-p o) + (scl-inspect o)) + (t + (call-next-method))))) + + +(defmethod emacs-inspect ((o kernel:code-component)) + (append + (label-value-line* + ("code-size" (kernel:%code-code-size o)) + ("entry-points" (kernel:%code-entry-points o)) + ("debug-info" (kernel:%code-debug-info o)) + ("trace-table-offset" (kernel:code-header-ref + o vm:code-trace-table-offset-slot))) + `("Constants:" (:newline)) + (loop for i from vm:code-constants-offset + below (kernel:get-header-data o) + append (label-value-line i (kernel:code-header-ref o i))) + `("Code:" (:newline) + , (with-output-to-string (s) + (cond ((kernel:%code-debug-info o) + (disassem:disassemble-code-component o :stream s)) + (t + (disassem:disassemble-memory + (disassem::align + (+ (logandc2 (kernel:get-lisp-obj-address o) + vm:lowtag-mask) + (* vm:code-constants-offset vm:word-bytes)) + (ash 1 vm:lowtag-bits)) + (ash (kernel:%code-code-size o) vm:word-shift) + :stream s))))))) + +(defmethod emacs-inspect ((o kernel:fdefn)) + (label-value-line* + ("name" (kernel:fdefn-name o)) + ("function" (kernel:fdefn-function o)) + ("raw-addr" (sys:sap-ref-32 + (sys:int-sap (kernel:get-lisp-obj-address o)) + (* vm:fdefn-raw-addr-slot vm:word-bytes))))) + +(defmethod emacs-inspect ((o array)) + (cond ((kernel:array-header-p o) + (list* (format nil "~A is an array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:rank (array-rank o)) + (:fill-pointer (kernel:%array-fill-pointer o)) + (:fill-pointer-p (kernel:%array-fill-pointer-p o)) + (:elements (kernel:%array-available-elements o)) + (:data (kernel:%array-data-vector o)) + (:displacement (kernel:%array-displacement o)) + (:displaced-p (kernel:%array-displaced-p o)) + (:dimensions (array-dimensions o))))) + (t + (list* (format nil "~A is an simple-array.~%" o) + (label-value-line* + (:header (describe-primitive-type o)) + (:length (length o))))))) + +(defmethod emacs-inspect ((o simple-vector)) + (list* (format nil "~A is a vector.~%" o) + (append + (label-value-line* + (:header (describe-primitive-type o)) + (:length (c::vector-length o))) + (unless (eq (array-element-type o) 'nil) + (loop for i below (length o) + append (label-value-line i (aref o i))))))) + +(defun inspect-alien-record (alien) + (with-struct (alien::alien-value- sap type) alien + (with-struct (alien::alien-record-type- kind name fields) type + (append + (label-value-line* + (:sap sap) + (:kind kind) + (:name name)) + (loop for field in fields + append (let ((slot (alien::alien-record-field-name field))) + (label-value-line slot (alien:slot alien slot)))))))) + +(defun inspect-alien-pointer (alien) + (with-struct (alien::alien-value- sap type) alien + (label-value-line* + (:sap sap) + (:type type) + (:to (alien::deref alien))))) + +(defun inspect-alien-value (alien) + (typecase (alien::alien-value-type alien) + (alien::alien-record-type (inspect-alien-record alien)) + (alien::alien-pointer-type (inspect-alien-pointer alien)) + (t (scl-inspect alien)))) + +;;;; Profiling +(defimplementation profile (fname) + (eval `(profile:profile ,fname))) + +(defimplementation unprofile (fname) + (eval `(profile:unprofile ,fname))) + +(defimplementation unprofile-all () + (eval `(profile:unprofile)) + "All functions unprofiled.") + +(defimplementation profile-report () + (eval `(profile:report-time))) + +(defimplementation profile-reset () + (eval `(profile:reset-time)) + "Reset profiling counters.") + +(defimplementation profiled-functions () + profile:*timed-functions*) + +(defimplementation profile-package (package callers methods) + (profile:profile-all :package package + :callers-p callers + #+nil :methods #+nil methods)) + + +;;;; Multiprocessing + +(defimplementation spawn (fn &key name) + (thread:thread-create fn :name (or name "Anonymous"))) + +(defvar *thread-id-counter* 0) +(defvar *thread-id-counter-lock* (thread:make-lock "Thread ID counter")) + +(defimplementation thread-id (thread) + (thread:with-lock-held (*thread-id-counter-lock*) + (or (getf (thread:thread-plist thread) 'id) + (setf (getf (thread:thread-plist thread) 'id) + (incf *thread-id-counter*))))) + +(defimplementation find-thread (id) + (block find-thread + (thread:map-over-threads + #'(lambda (thread) + (when (eql (getf (thread:thread-plist thread) 'id) id) + (return-from find-thread thread)))))) + +(defimplementation thread-name (thread) + (princ-to-string (thread:thread-name thread))) + +(defimplementation thread-status (thread) + (let ((dynamic-values (thread::thread-dynamic-values thread))) + (if (zerop dynamic-values) "Exited" "Running"))) + +(defimplementation make-lock (&key name) + (thread:make-lock name)) + +(defimplementation call-with-lock-held (lock function) + (declare (type function function)) + (thread:with-lock-held (lock) (funcall function))) + +(defimplementation current-thread () + thread:*thread*) + +(defimplementation all-threads () + (let ((all-threads nil)) + (thread:map-over-threads #'(lambda (thread) (push thread all-threads))) + all-threads)) + +(defimplementation interrupt-thread (thread fn) + (thread:thread-interrupt thread #'(lambda () + (sys:with-interrupts + (funcall fn))))) + +(defimplementation kill-thread (thread) + (thread:destroy-thread thread)) + +(defimplementation thread-alive-p (thread) + (not (zerop (thread::thread-dynamic-values thread)))) + +(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil)) + +(defstruct (mailbox) + (lock (thread:make-lock "Thread mailbox" :type :error-check + :interruptible nil) + :type thread:error-check-lock) + (queue '() :type list)) + +(defun mailbox (thread) + "Return 'thread's mailbox." + (sys:without-interrupts + (thread:with-lock-held (*mailbox-lock*) + (or (getf (thread:thread-plist thread) 'mailbox) + (setf (getf (thread:thread-plist thread) 'mailbox) + (make-mailbox)))))) + +(defimplementation send (thread message) + (let* ((mbox (mailbox thread)) + (lock (mailbox-lock mbox))) + (sys:without-interrupts + (thread:with-lock-held (lock "Mailbox Send") + (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox) + (list message))))) + (mp:process-wakeup thread))) + +#+nil +(defimplementation receive () + (receive-if (constantly t))) + +(defimplementation receive-if (test &optional timeout) + (let ((mbox (mailbox thread:*thread*))) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (sys:without-interrupts + (mp:with-lock-held ((mailbox-lock mbox)) + (let* ((q (mailbox-queue mbox)) + (tail (member-if test q))) + (when tail + (setf (mailbox-queue mbox) + (nconc (ldiff q tail) (cdr tail))) + (return (car tail)))))) + (when (eq timeout t) (return (values nil t))) + (mp:process-wait-with-timeout + "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox))))))) + + + +(defimplementation emacs-connected ()) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;Trace implementations +;; In SCL, we have: +;; (trace ) +;; (trace (method ? (+))) +;; (trace :methods t ') ;;to trace all methods of the gf +;; can be a normal name or a (setf name) + +(defun tracedp (spec) + (member spec (eval '(trace)) :test #'equal)) + +(defun toggle-trace-aux (spec &rest options) + (cond ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec ,@options)) + (format nil "~S is now traced." spec)))) + +(defimplementation toggle-trace (spec) + (ecase (car spec) + ((setf) + (toggle-trace-aux spec)) + ((:defgeneric) + (let ((name (second spec))) + (toggle-trace-aux name :methods name))) + ((:defmethod) + nil) + ((:call) + (destructuring-bind (caller callee) (cdr spec) + (toggle-trace-aux (process-fspec callee) + :wherein (list (process-fspec caller))))))) + +(defun process-fspec (fspec) + (cond ((consp fspec) + (ecase (first fspec) + ((:defun :defgeneric) (second fspec)) + ((:defmethod) + `(method ,(second fspec) ,@(third fspec) ,(fourth fspec))) + ;; this isn't actually supported + ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec))) + ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec))))) + (t + fspec))) + +;;; Weak datastructures + +;;; Not implemented in SCL. +(defimplementation make-weak-key-hash-table (&rest args) + (apply #'make-hash-table :weak-p t args)) blob - /dev/null blob + 7226b091389b3a248bcb9ab901ab95cc77cdd9ff (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/metering.lisp @@ -0,0 +1,1235 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10.; -*- +;;; Tue Jan 25 18:32:28 1994 by Mark Kantrowitz + +;;; **************************************************************** +;;; Metering System ************************************************ +;;; **************************************************************** +;;; +;;; The Metering System is a portable Common Lisp code profiling tool. +;;; It gathers timing and consing statistics for specified functions +;;; while a program is running. +;;; +;;; The Metering System is a combination of +;;; o the Monitor package written by Chris McConnell +;;; o the Profile package written by Skef Wholey and Rob MacLachlan +;;; The two systems were merged and extended by Mark Kantrowitz. +;;; +;;; Address: Carnegie Mellon University +;;; School of Computer Science +;;; Pittsburgh, PA 15213 +;;; +;;; This code is in the public domain and is distributed without warranty +;;; of any kind. +;;; +;;; This copy is from SLY, http://www.common-lisp.net/project/sly/ +;;; +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 26-JUN-90 mk Merged functionality of Monitor and Profile packages. +;;; 26-JUN-90 mk Now handles both inclusive and exclusive statistics +;;; with respect to nested calls. (Allows it to subtract +;;; total monitoring overhead for each function, not just +;;; the time spent monitoring the function itself.) +;;; 26-JUN-90 mk The table is now saved so that one may manipulate +;;; the data (sorting it, etc.) even after the original +;;; source of the data has been cleared. +;;; 25-SEP-90 mk Added get-cons functions for Lucid 3.0, MACL 1.3.2 +;;; required-arguments functions for Lucid 3.0, +;;; Franz Allegro CL, and MACL 1.3.2. +;;; 25-JAN-91 mk Now uses fdefinition if available. +;;; 25-JAN-91 mk Replaced (and :allegro (not :coral)) with :excl. +;;; Much better solution for the fact that both call +;;; themselves :allegro. +;;; 5-JUL-91 mk Fixed warning to occur only when file is loaded +;;; uncompiled. +;;; 5-JUL-91 mk When many unmonitored functions, print out number +;;; instead of whole list. +;;; 24-MAR-92 mk Updated for CLtL2 compatibility. space measuring +;;; doesn't work in MCL, but fixed so that timing +;;; statistics do. +;;; 26-MAR-92 mk Updated for Lispworks. Replaced :ccl with +;;; (and :ccl (not :lispworks)). +;;; 27-MAR-92 mk Added get-cons for Allegro-V4.0. +;;; 01-JAN-93 mk v2.0 Support for MCL 2.0, CMU CL 16d, Allegro V3.1/4.0/4.1, +;;; Lucid 4.0, ibcl +;;; 25-JAN-94 mk v2.1 Patches for CLISP from Bruno Haible. +;;; 01-APR-05 lgorrie Removed support for all Lisps except CLISP and OpenMCL. +;;; Purely to cut down on stale code (e.g. #+cltl2) in this +;;; version that is bundled with SLY. +;;; 22-Aug-08 stas Define TIME-TYPE for Clozure CL. +;;; 07-Aug-12 heller Break lines at 80 columns +;;; + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; - Need get-cons for Allegro, AKCL. +;;; - Speed up monitoring code. Replace use of hash tables with an embedded +;;; offset in an array so that it will be faster than using gethash. +;;; (i.e., svref/closure reference is usually faster than gethash). +;;; - Beware of (get-internal-run-time) overflowing. Yikes! +;;; - Check robustness with respect to profiled functions. +;;; - Check logic of computing inclusive and exclusive time and consing. +;;; Especially wrt incf/setf comment below. Should be incf, so we +;;; sum recursive calls. +;;; - Add option to record caller statistics -- this would list who +;;; called which functions and how often. +;;; - switches to turn timing/CONSING statistics collection on/off. + + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; METERING has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (16d, Python Compiler 1.0 ) :new-compiler +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; Macintosh Common Lisp (2.0) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 11/19/90) :allegro-v3.1 +;;; ExCL (Franz Allegro CL 4.0.1 [Sun4] 2/8/91) :allegro-v4.0 +;;; ExCL (Franz Allegro CL 4.1 [SPARC R1] 8/28/92 14:06) :allegro-v4.1 +;;; ExCL (Franz ACL 5.0.1 [Linux/X86] 6/29/99 16:11) :allegro-v5.0.1 +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; Lucid Common Lisp (3.0) +;;; Lucid Common Lisp (4.0.1 HP-700 12-Aug-91) +;;; AKCL (1.86, June 30, 1987 or later) +;;; Ibuki Common Lisp (Version 2, release 01.027) +;;; CLISP (January 1994) +;;; +;;; METERING needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; KCL (June 3, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; This system runs in any valid Common Lisp. Four small +;;; implementation-dependent changes can be made to improve performance +;;; and prettiness. In the section labelled "Implementation Dependent +;;; Changes" below, you should tailor the functions REQUIRED-ARGUMENTS, +;;; GET-CONS, GET-TIME, and TIME-UNITS-PER-SECOND to your implementation +;;; for the best results. If GET-CONS is not specified for your +;;; implementation, no consing information will be reported. The other +;;; functions will default to working forms, albeit inefficient, in +;;; non-CMU implementations. If you tailor these functions for a particular +;;; version of Common Lisp, we'd appreciate receiving the code. +;;; + +;;; **************************************************************** +;;; Usage Notes **************************************************** +;;; **************************************************************** +;;; +;;; SUGGESTED USAGE: +;;; +;;; Start by monitoring big pieces of the program, then carefully choose +;;; which functions close to, but not in, the inner loop are to be +;;; monitored next. Don't monitor functions that are called by other +;;; monitored functions: you will only confuse yourself. +;;; +;;; If the per-call time reported is less than 1/10th of a second, then +;;; consider the clock resolution and profiling overhead before you believe +;;; the time. It may be that you will need to run your program many times +;;; in order to average out to a higher resolution. +;;; +;;; The easiest way to use this package is to load it and execute either +;;; (slynk-monitor:with-monitoring (names*) () +;;; your-forms*) +;;; or +;;; (slynk-monitor:monitor-form your-form) +;;; The former allows you to specify which functions will be monitored; the +;;; latter monitors all functions in the current package. Both automatically +;;; produce a table of statistics. Other variants can be constructed from +;;; the monitoring primitives, which are described below, along with a +;;; fuller description of these two macros. +;;; +;;; For best results, compile this file before using. +;;; +;;; +;;; CLOCK RESOLUTION: +;;; +;;; Unless you are very lucky, the length of your machine's clock "tick" is +;;; probably much longer than the time it takes a simple function to run. +;;; For example, on the IBM RT, the clock resolution is 1/50th of a second. +;;; This means that if a function is only called a few times, then only the +;;; first couple of decimal places are really meaningful. +;;; +;;; +;;; MONITORING OVERHEAD: +;;; +;;; The added monitoring code takes time to run every time that the monitored +;;; function is called, which can disrupt the attempt to collect timing +;;; information. In order to avoid serious inflation of the times for functions +;;; that take little time to run, an estimate of the overhead due to monitoring +;;; is subtracted from the times reported for each function. +;;; +;;; Although this correction works fairly well, it is not totally accurate, +;;; resulting in times that become increasingly meaningless for functions +;;; with short runtimes. For example, subtracting the estimated overhead +;;; may result in negative times for some functions. This is only a concern +;;; when the estimated profiling overhead is many times larger than +;;; reported total CPU time. +;;; +;;; If you monitor functions that are called by monitored functions, in +;;; :inclusive mode the monitoring overhead for the inner function is +;;; subtracted from the CPU time for the outer function. [We do this by +;;; counting for each function not only the number of calls to *this* +;;; function, but also the number of monitored calls while it was running.] +;;; In :exclusive mode this is not necessary, since we subtract the +;;; monitoring time of inner functions, overhead & all. +;;; +;;; Otherwise, the estimated monitoring overhead is not represented in the +;;; reported total CPU time. The sum of total CPU time and the estimated +;;; monitoring overhead should be close to the total CPU time for the +;;; entire monitoring run (as determined by TIME). +;;; +;;; A timing overhead factor is computed at load time. This will be incorrect +;;; if the monitoring code is run in a different environment than this file +;;; was loaded in. For example, saving a core image on a high performance +;;; machine and running it on a low performance one will result in the use +;;; of an erroneously small overhead factor. +;;; +;;; +;;; If your times vary widely, possible causes are: +;;; - Garbage collection. Try turning it off, then running your code. +;;; Be warned that monitoring code will probably cons when it does +;;; (get-internal-run-time). +;;; - Swapping. If you have enough memory, execute your form once +;;; before monitoring so that it will be swapped into memory. Otherwise, +;;; get a bigger machine! +;;; - Resolution of internal-time-units-per-second. If this value is +;;; too low, then the timings become wild. You can try executing more +;;; of whatever your test is, but that will only work if some of your +;;; paths do not match the timer resolution. +;;; internal-time-units-per-second is so coarse -- on a Symbolics it is +;;; 977, in MACL it is 60. +;;; +;;; + +;;; **************************************************************** +;;; Interface ****************************************************** +;;; **************************************************************** +;;; +;;; WITH-MONITORING (&rest functions) [Macro] +;;; (&optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time)) +;;; &body body +;;; The named functions will be set up for monitoring, the body forms executed, +;;; a table of results printed, and the functions unmonitored. The nested, +;;; threshold, and key arguments are passed to report-monitoring below. +;;; +;;; MONITOR-FORM form [Macro] +;;; &optional (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; All functions in the current package are set up for monitoring while +;;; the form is executed, and automatically unmonitored after a table of +;;; results has been printed. The nested, threshold, and key arguments +;;; are passed to report-monitoring below. +;;; +;;; *MONITORED-FUNCTIONS* [Variable] +;;; This holds a list of all functions that are currently being monitored. +;;; +;;; MONITOR &rest names [Macro] +;;; The named functions will be set up for monitoring by augmenting +;;; their function definitions with code that gathers statistical information +;;; about code performance. As with the TRACE macro, the function names are +;;; not evaluated. Calls the function SLYNK-MONITOR::MONITORING-ENCAPSULATE on each +;;; function name. If no names are specified, returns a list of all +;;; monitored functions. +;;; +;;; If name is not a symbol, it is evaled to return the appropriate +;;; closure. This allows you to monitor closures stored anywhere like +;;; in a variable, array or structure. Most other monitoring packages +;;; can't handle this. +;;; +;;; MONITOR-ALL &optional (package *package*) [Function] +;;; Monitors all functions in the specified package, which defaults to +;;; the current package. +;;; +;;; UNMONITOR &rest names [Macro] +;;; Removes monitoring code from the named functions. If no names are +;;; specified, all currently monitored functions are unmonitored. +;;; +;;; RESET-MONITORING-INFO name [Function] +;;; Resets the monitoring statistics for the specified function. +;;; +;;; RESET-ALL-MONITORING [Function] +;;; Resets the monitoring statistics for all monitored functions. +;;; +;;; MONITORED name [Function] +;;; Predicate to test whether a function is monitored. +;;; +;;; REPORT-MONITORING &optional names [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (key :percent-time) +;;; Creates a table of monitoring information for the specified list +;;; of names, and displays the table using display-monitoring-results. +;;; If names is :all or nil, uses all currently monitored functions. +;;; Takes the following arguments: +;;; - NESTED specifies whether nested calls of monitored functions +;;; are included in the times for monitored functions. +;;; o If :inclusive, the per-function information is for the entire +;;; duration of the monitored function, including any calls to +;;; other monitored functions. If functions A and B are monitored, +;;; and A calls B, then the accumulated time and consing for A will +;;; include the time and consing of B. Note: if a function calls +;;; itself recursively, the time spent in the inner call(s) may +;;; be counted several times. +;;; o If :exclusive, the information excludes time attributed to +;;; calls to other monitored functions. This is the default. +;;; - THRESHOLD specifies that only functions which have been executed +;;; more than threshold percent of the time will be reported. Defaults +;;; to 1%. If a threshold of 0 is specified, all functions are listed, +;;; even those with 0 or negative running times (see note on overhead). +;;; - KEY specifies that the table be sorted by one of the following +;;; sort keys: +;;; :function alphabetically by function name +;;; :percent-time by percent of total execution time +;;; :percent-cons by percent of total consing +;;; :calls by number of times the function was called +;;; :time-per-call by average execution time per function +;;; :cons-per-call by average consing per function +;;; :time same as :percent-time +;;; :cons same as :percent-cons +;;; +;;; REPORT &key (names :all) [Function] +;;; (nested :exclusive) +;;; (threshold 0.01) +;;; (sort-key :percent-time) +;;; (ignore-no-calls nil) +;;; +;;; Same as REPORT-MONITORING but we use a nicer keyword interface. +;;; +;;; DISPLAY-MONITORING-RESULTS &optional (threshold 0.01) [Function] +;;; (key :percent-time) +;;; Prints a table showing for each named function: +;;; - the total CPU time used in that function for all calls +;;; - the total number of bytes consed in that function for all calls +;;; - the total number of calls +;;; - the average amount of CPU time per call +;;; - the average amount of consing per call +;;; - the percent of total execution time spent executing that function +;;; - the percent of total consing spent consing in that function +;;; Summary totals of the CPU time, consing, and calls columns are printed. +;;; An estimate of the monitoring overhead is also printed. May be run +;;; even after unmonitoring all the functions, to play with the data. +;;; +;;; SAMPLE TABLE: +#| + Cons + % % Per Total Total +Function Time Cons Calls Sec/Call Call Time Cons +---------------------------------------------------------------------- +FIND-ROLE: 0.58 0.00 136 0.003521 0 0.478863 0 +GROUP-ROLE: 0.35 0.00 365 0.000802 0 0.292760 0 +GROUP-PROJECTOR: 0.05 0.00 102 0.000408 0 0.041648 0 +FEATURE-P: 0.02 0.00 570 0.000028 0 0.015680 0 +---------------------------------------------------------------------- +TOTAL: 1173 0.828950 0 +Estimated total monitoring overhead: 0.88 seconds +|# + +;;; **************************************************************** +;;; METERING ******************************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Warn people using the wrong Lisp +;;; ******************************** + +#-(or clisp openmcl clasp) +(warn "metering.lisp does not support your Lisp implementation!") + +;;; ******************************** +;;; Packages *********************** +;;; ******************************** + +;;; For CLtL2 compatible lisps + +(defpackage "SLYNK-MONITOR" (:use "COMMON-LISP") + (:export "*MONITORED-FUNCTIONS*" + "MONITOR" "MONITOR-ALL" "UNMONITOR" "MONITOR-FORM" + "WITH-MONITORING" + "RESET-MONITORING-INFO" "RESET-ALL-MONITORING" + "MONITORED" + "REPORT-MONITORING" + "DISPLAY-MONITORING-RESULTS" + "MONITORING-ENCAPSULATE" "MONITORING-UNENCAPSULATE" + "REPORT")) +(in-package "SLYNK-MONITOR") + +;;; Warn user if they're loading the source instead of compiling it first. +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + +;;; ******************************** +;;; Version ************************ +;;; ******************************** + +(defparameter *metering-version* "v2.1 25-JAN-94" + "Current version number/date for Metering.") + + +;;; **************************************************************** +;;; Implementation Dependent Definitions *************************** +;;; **************************************************************** + +;;; ******************************** +;;; Timing Functions *************** +;;; ******************************** +;;; The get-time function is called to find the total number of ticks since +;;; the beginning of time. time-units-per-second allows us to convert units +;;; to seconds. + +#-(or clasp clisp openmcl) +(eval-when (compile eval) + (warn + "You may want to supply implementation-specific get-time functions.")) + +(defconstant time-units-per-second internal-time-units-per-second) + +#+(or clasp openmcl) +(progn + (deftype time-type () 'unsigned-byte) + (deftype consing-type () 'unsigned-byte)) + +(defmacro get-time () + `(the time-type (get-internal-run-time))) + +;;; NOTE: In Macintosh Common Lisp, CCL::GCTIME returns the number of +;;; milliseconds spent during GC. We could subtract this from +;;; the value returned by get-internal-run-time to eliminate +;;; the effect of GC on the timing values, but we prefer to let +;;; the user run without GC on. If the application is so big that +;;; it requires GC to complete, then the GC times are part of the +;;; cost of doing business, and will average out in the long run. +;;; If it seems really important to a user that GC times not be +;;; counted, then uncomment the following three lines and read-time +;;; conditionalize the definition of get-time above with #-:openmcl. +;#+openmcl +;(defmacro get-time () +; `(the time-type (- (get-internal-run-time) (ccl:gctime)))) + +;;; ******************************** +;;; Consing Functions ************** +;;; ******************************** +;;; The get-cons macro is called to find the total number of bytes +;;; consed since the beginning of time. + +#+clisp +(defun get-cons () + (multiple-value-bind (real1 real2 run1 run2 gc1 gc2 space1 space2 gccount) + (sys::%%time) + (declare (ignore real1 real2 run1 run2 gc1 gc2 gccount)) + (dpb space1 (byte 24 24) space2))) + +;;; Macintosh Common Lisp 2.0 +;;; Note that this includes bytes that were allocated during GC. +;;; We could subtract this out by advising GC like we did under +;;; MCL 1.3.2, but I'd rather users ran without GC. If they can't +;;; run without GC, then the bytes consed during GC are a cost of +;;; running their program. Metering the code a few times will +;;; avoid the consing values being too lopsided. If a user really really +;;; wants to subtract out the consing during GC, replace the following +;;; two lines with the commented out code. +#+openmcl +(defmacro get-cons () `(the consing-type (ccl::total-bytes-allocated))) + +#+clasp +(defmacro get-cons () + `(the consing-type (gctools::bytes-allocated))) + +#-(or clasp clisp openmcl) +(progn + (eval-when (compile eval) + (warn "No consing will be reported unless a get-cons function is ~ + defined.")) + + (defmacro get-cons () '(the consing-type 0))) + +;; actually, neither `get-cons' nor `get-time' are used as is, +;; but only in the following macro `with-time/cons' +#-:clisp +(defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((start-cons (gensym "START-CONS-")) + (start-time (gensym "START-TIME-"))) + `(let ((,start-time (get-time)) (,start-cons (get-cons))) + (declare (type time-type ,start-time) + (type consing-type ,start-cons)) + (multiple-value-prog1 ,form + (let ((,delta-time (- (get-time) ,start-time)) + (,delta-cons (- (get-cons) ,start-cons))) + ,@post-process))))) + +#+clisp +(progn + (defmacro delta4 (nv1 nv2 ov1 ov2 by) + `(- (dpb (- ,nv1 ,ov1) (byte ,by ,by) ,nv2) ,ov2)) + + (let ((del (find-symbol "DELTA4" "SYS"))) + (when del (setf (fdefinition 'delta4) (fdefinition del)))) + + (if (< internal-time-units-per-second 1000000) + ;; TIME_1: AMIGA, OS/2, UNIX_TIMES + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(delta4 ,new-time1 ,new-time2 ,old-time1 ,old-time2 16)) + ;; TIME_2: other UNIX, WIN32 + (defmacro delta4-time (new-time1 new-time2 old-time1 old-time2) + `(+ (* (- ,new-time1 ,old-time1) internal-time-units-per-second) + (- ,new-time2 ,old-time2)))) + + (defmacro delta4-cons (new-cons1 new-cons2 old-cons1 old-cons2) + `(delta4 ,new-cons1 ,new-cons2 ,old-cons1 ,old-cons2 24)) + + ;; avoid consing: when the application conses a lot, + ;; get-cons may return a bignum, so we really should not use it. + (defmacro with-time/cons ((delta-time delta-cons) form &body post-process) + (let ((beg-cons1 (gensym "BEG-CONS1-")) (end-cons1 (gensym "END-CONS1-")) + (beg-cons2 (gensym "BEG-CONS2-")) (end-cons2 (gensym "END-CONS2-")) + (beg-time1 (gensym "BEG-TIME1-")) (end-time1 (gensym "END-TIME1-")) + (beg-time2 (gensym "BEG-TIME2-")) (end-time2 (gensym "END-TIME2-")) + (re1 (gensym)) (re2 (gensym)) (gc1 (gensym)) (gc2 (gensym))) + `(multiple-value-bind (,re1 ,re2 ,beg-time1 ,beg-time2 + ,gc1 ,gc2 ,beg-cons1 ,beg-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (multiple-value-prog1 ,form + (multiple-value-bind (,re1 ,re2 ,end-time1 ,end-time2 + ,gc1 ,gc2 ,end-cons1 ,end-cons2) + (sys::%%time) + (declare (ignore ,re1 ,re2 ,gc1 ,gc2)) + (let ((,delta-time (delta4-time ,end-time1 ,end-time2 + ,beg-time1 ,beg-time2)) + (,delta-cons (delta4-cons ,end-cons1 ,end-cons2 + ,beg-cons1 ,beg-cons2))) + ,@post-process))))))) + +;;; ******************************** +;;; Required Arguments ************* +;;; ******************************** +;;; +;;; Required (Fixed) vs Optional Args +;;; +;;; To avoid unnecessary consing in the "encapsulation" code, we find out the +;;; number of required arguments, and use &rest to capture only non-required +;;; arguments. The function Required-Arguments returns two values: the first +;;; is the number of required arguments, and the second is T iff there are any +;;; non-required arguments (e.g. &optional, &rest, &key). + +;;; Lucid, Allegro, and Macintosh Common Lisp +#+openmcl +(defun required-arguments (name) + (let* ((function (symbol-function name)) + (args (ccl:arglist function)) + (pos (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + args))) + (if pos + (values pos t) + (values (length args) nil)))) + +#+clisp +(defun required-arguments (name) + (multiple-value-bind (name req-num opt-num rest-p key-p keywords allow-p) + (sys::function-signature name t) + (if name ; no error + (values req-num (or (/= 0 opt-num) rest-p key-p keywords allow-p)) + (values 0 t)))) + +#+clasp +(defun required-arguments (name) + (multiple-value-bind (arglist foundp) + (core:function-lambda-list name) + (if foundp + (let ((position-and + (position-if #'(lambda (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 1) + (char= (schar name 0) + #\&))))) + arglist))) + (if position-and + (values position-and t) + (values (length arglist) nil))) + (values 0 t)))) + +#-(or clasp clisp openmcl) +(progn + (eval-when (compile eval) + (warn + "You may want to add an implementation-specific ~ +Required-Arguments function.")) + (eval-when (load eval) + (defun required-arguments (name) + (declare (ignore name)) + (values 0 t)))) + +#| +;;;Examples +(defun square (x) (* x x)) +(defun square2 (x &optional y) (* x x y)) +(defun test (x y &optional (z 3)) 3) +(defun test2 (x y &optional (z 3) &rest fred) 3) + +(required-arguments 'square) => 1 nil +(required-arguments 'square2) => 1 t +(required-arguments 'test) => 2 t +(required-arguments 'test2) => 2 t +|# + + +;;; **************************************************************** +;;; Main METERING Code ********************************************* +;;; **************************************************************** + +;;; ******************************** +;;; Global Variables *************** +;;; ******************************** +(defvar *MONITOR-TIME-OVERHEAD* nil + "The amount of time an empty monitored function costs.") +(defvar *MONITOR-CONS-OVERHEAD* nil + "The amount of cons an empty monitored function costs.") + +(defvar *TOTAL-TIME* 0 + "Total amount of time monitored so far.") +(defvar *TOTAL-CONS* 0 + "Total amount of consing monitored so far.") +(defvar *TOTAL-CALLS* 0 + "Total number of calls monitored so far.") +(proclaim '(type time-type *total-time*)) +(proclaim '(type consing-type *total-cons*)) +(proclaim '(fixnum *total-calls*)) + +;;; ******************************** +;;; Accessor Functions ************* +;;; ******************************** +;;; Perhaps the SYMBOLP should be FBOUNDP? I.e., what about variables +;;; containing closures. +(defmacro PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + ;; Note that (fboundp 'fdefinition) returns T even if fdefinition + ;; is a macro, which is what we want. + (if (fboundp 'fdefinition) + `(if (fboundp ,function-place) + (fdefinition ,function-place) + (eval ,function-place)) + `(if (symbolp ,function-place) + (symbol-function ,function-place) + (eval ,function-place)))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + (if (fboundp 'fdefinition) + ;; If we're conforming to CLtL2, use fdefinition here. + `(if (fboundp ,function-place) + (setf (fdefinition ,function-place) ,function) + (eval '(setf ,function-place ',function))) + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function))))) + +#| +;;; before using fdefinition +(defun PLACE-FUNCTION (function-place) + "Return the function found at FUNCTION-PLACE. Evals FUNCTION-PLACE +if it isn't a symbol, to allow monitoring of closures located in +variables/arrays/structures." + (if (symbolp function-place) + (symbol-function function-place) + (eval function-place))) + +(defsetf PLACE-FUNCTION (function-place) (function) + "Set the function in FUNCTION-PLACE to FUNCTION." + `(if (symbolp ,function-place) + (setf (symbol-function ,function-place) ,function) + (eval '(setf ,function-place ',function)))) +|# + +(defun PLACE-FBOUNDP (function-place) + "Test to see if FUNCTION-PLACE is a function." + ;; probably should be + #|(or (and (symbolp function-place)(fboundp function-place)) + (functionp (place-function function-place)))|# + (if (symbolp function-place) + (fboundp function-place) + (functionp (place-function function-place)))) + +(defun PLACE-MACROP (function-place) + "Test to see if FUNCTION-PLACE is a macro." + (when (symbolp function-place) + (macro-function function-place))) + +;;; ******************************** +;;; Measurement Tables ************* +;;; ******************************** +(defvar *monitored-functions* nil + "List of monitored symbols.") + +;;; We associate a METERING-FUNCTIONS structure with each monitored function +;;; name or other closure. This holds the functions that we call to manipulate +;;; the closure which implements the encapsulation. +;;; +(defstruct metering-functions + (name nil) + (old-definition nil :type function) + (new-definition nil :type function) + (read-metering nil :type function) + (reset-metering nil :type function)) + +;;; In general using hash tables in time-critical programs is a bad idea, +;;; because when one has to grow the table and rehash everything, the +;;; timing becomes grossly inaccurate. In this case it is not an issue +;;; because all inserting of entries in the hash table occurs before the +;;; timing commences. The only circumstance in which this could be a +;;; problem is if the lisp rehashes on the next reference to the table, +;;; instead of when the entry which forces a rehash was inserted. +;;; +;;; Note that a similar kind of problem can occur with GC, which is why +;;; one should turn off GC when monitoring code. +;;; +(defvar *monitor* (make-hash-table :test #'equal) + "Hash table in which METERING-FUNCTIONS structures are stored.") +(defun get-monitor-info (name) + (gethash name *monitor*)) +(defsetf get-monitor-info (name) (info) + `(setf (gethash ,name *monitor*) ,info)) + +(defun MONITORED (function-place) + "Test to see if a FUNCTION-PLACE is monitored." + (and (place-fboundp function-place) ; this line necessary? + (get-monitor-info function-place))) + +(defun reset-monitoring-info (name) + "Reset the monitoring info for the specified function." + (let ((finfo (get-monitor-info name))) + (when finfo + (funcall (metering-functions-reset-metering finfo))))) +(defun reset-all-monitoring () + "Reset monitoring info for all functions." + (setq *total-time* 0 + *total-cons* 0 + *total-calls* 0) + (dolist (symbol *monitored-functions*) + (when (monitored symbol) + (reset-monitoring-info symbol)))) + +(defun monitor-info-values (name &optional (nested :exclusive) warn) + "Returns monitoring information values for the named function, +adjusted for overhead." + (let ((finfo (get-monitor-info name))) + (if finfo + (multiple-value-bind (inclusive-time inclusive-cons + exclusive-time exclusive-cons + calls nested-calls) + (funcall (metering-functions-read-metering finfo)) + (unless (or (null warn) + (eq (place-function name) + (metering-functions-new-definition finfo))) + (warn "Funtion ~S has been redefined, so times may be inaccurate.~@ + MONITOR it again to record calls to the new definition." + name)) + (case nested + (:exclusive (values calls + nested-calls + (- exclusive-time + (* calls *monitor-time-overhead*)) + (- exclusive-cons + (* calls *monitor-cons-overhead*)))) + ;; In :inclusive mode, subtract overhead for all the + ;; called functions as well. Nested-calls includes the + ;; calls of the function as well. [Necessary 'cause of + ;; functions which call themselves recursively.] + (:inclusive (values calls + nested-calls + (- inclusive-time + (* nested-calls ;(+ calls) + *monitor-time-overhead*)) + (- inclusive-cons + (* nested-calls ;(+ calls) + *monitor-cons-overhead*)))))) + (values 0 0 0 0)))) + +;;; ******************************** +;;; Encapsulate ******************** +;;; ******************************** +(eval-when (compile load eval) +;; Returns a lambda expression for a function that, when called with the +;; function name, will set up that function for metering. +;; +;; A function is monitored by replacing its definition with a closure +;; created by the following function. The closure records the monitoring +;; data, and updates the data with each call of the function. +;; +;; Other closures are used to read and reset the data. +(defun make-monitoring-encapsulation (min-args optionals-p) + (let (required-args) + (dotimes (i min-args) (push (gensym) required-args)) + `(lambda (name) + (let ((inclusive-time 0) + (inclusive-cons 0) + (exclusive-time 0) + (exclusive-cons 0) + (calls 0) + (nested-calls 0) + (old-definition (place-function name))) + (declare (type time-type inclusive-time) + (type time-type exclusive-time) + (type consing-type inclusive-cons) + (type consing-type exclusive-cons) + (fixnum calls) + (fixnum nested-calls)) + (pushnew name *monitored-functions*) + + (setf (place-function name) + #'(lambda (,@required-args + ,@(when optionals-p + `(&rest optional-args))) + (let ((prev-total-time *total-time*) + (prev-total-cons *total-cons*) + (prev-total-calls *total-calls*) + ;; (old-time inclusive-time) + ;; (old-cons inclusive-cons) + ;; (old-nested-calls nested-calls) + ) + (declare (type time-type prev-total-time) + (type consing-type prev-total-cons) + (fixnum prev-total-calls)) + (with-time/cons (delta-time delta-cons) + ;; form + ,(if optionals-p + `(apply old-definition + ,@required-args optional-args) + `(funcall old-definition ,@required-args)) + ;; post-processing: + ;; Calls + (incf calls) + (incf *total-calls*) + ;; nested-calls includes this call + (incf nested-calls (the fixnum + (- *total-calls* + prev-total-calls))) + ;; (setf nested-calls (+ old-nested-calls + ;; (- *total-calls* + ;; prev-total-calls))) + ;; Time + ;; Problem with inclusive time is that it + ;; currently doesn't add values from recursive + ;; calls to the same function. Change the + ;; setf to an incf to fix this? + (incf inclusive-time (the time-type delta-time)) + ;; (setf inclusive-time (+ delta-time old-time)) + (incf exclusive-time (the time-type + (+ delta-time + (- prev-total-time + *total-time*)))) + (setf *total-time* (the time-type + (+ delta-time + prev-total-time))) + ;; Consing + (incf inclusive-cons (the consing-type delta-cons)) + ;; (setf inclusive-cons (+ delta-cons old-cons)) + (incf exclusive-cons (the consing-type + (+ delta-cons + (- prev-total-cons + *total-cons*)))) + (setf *total-cons* + (the consing-type + (+ delta-cons prev-total-cons))))))) + (setf (get-monitor-info name) + (make-metering-functions + :name name + :old-definition old-definition + :new-definition (place-function name) + :read-metering #'(lambda () + (values inclusive-time + inclusive-cons + exclusive-time + exclusive-cons + calls + nested-calls)) + :reset-metering #'(lambda () + (setq inclusive-time 0 + inclusive-cons 0 + exclusive-time 0 + exclusive-cons 0 + calls 0 + nested-calls 0) + t))))))) +);; End of EVAL-WHEN + +;;; For efficiency reasons, we precompute the encapsulation functions +;;; for a variety of combinations of argument structures +;;; (min-args . optional-p). These are stored in the following hash table +;;; along with any new ones we encounter. Since we're now precomputing +;;; closure functions for common argument signatures, this eliminates +;;; the former need to call COMPILE for each monitored function. +(eval-when (compile eval) + (defconstant precomputed-encapsulations 8)) + +(defvar *existing-encapsulations* (make-hash-table :test #'equal)) +(defun find-encapsulation (min-args optionals-p) + (or (gethash (cons min-args optionals-p) *existing-encapsulations*) + (setf (gethash (cons min-args optionals-p) *existing-encapsulations*) + (compile nil + (make-monitoring-encapsulation min-args optionals-p))))) + +(macrolet ((frob () + (let ((res ())) + (dotimes (i precomputed-encapsulations) + (push `(setf (gethash '(,i . nil) *existing-encapsulations*) + #',(make-monitoring-encapsulation i nil)) + res) + (push `(setf (gethash '(,i . t) *existing-encapsulations*) + #',(make-monitoring-encapsulation i t)) + res)) + `(progn ,@res)))) + (frob)) + +(defun monitoring-encapsulate (name &optional warn) + "Monitor the function Name. If already monitored, unmonitor first." + ;; Saves the current definition of name and inserts a new function which + ;; returns the result of evaluating body. + (cond ((not (place-fboundp name)) ; not a function + (when warn + (warn "Ignoring undefined function ~S." name))) + ((place-macrop name) ; a macro + (when warn + (warn "Ignoring macro ~S." name))) + (t ; tis a function + (when (get-monitor-info name) ; monitored + (when warn + (warn "~S already monitored, so unmonitoring it first." name)) + (monitoring-unencapsulate name)) + (multiple-value-bind (min-args optionals-p) + (required-arguments name) + (funcall (find-encapsulation min-args optionals-p) name))))) + +(defun monitoring-unencapsulate (name &optional warn) + "Removes monitoring encapsulation code from around Name." + (let ((finfo (get-monitor-info name))) + (when finfo ; monitored + (remprop name 'metering-functions) + (setq *monitored-functions* + (remove name *monitored-functions* :test #'equal)) + (if (eq (place-function name) + (metering-functions-new-definition finfo)) + (setf (place-function name) + (metering-functions-old-definition finfo)) + (when warn + (warn "Preserving current definition of redefined function ~S." + name)))))) + +;;; ******************************** +;;; Main Monitoring Functions ****** +;;; ******************************** +(defmacro MONITOR (&rest names) + "Monitor the named functions. As in TRACE, the names are not evaluated. + If a function is already monitored, then unmonitor and remonitor (useful + to notice function redefinition). If a name is undefined, give a warning + and ignore it. See also unmonitor, report-monitoring, + display-monitoring-results and reset-time." + `(progn + ,@(mapcar #'(lambda (name) `(monitoring-encapsulate ',name)) names) + *monitored-functions*)) + +(defmacro UNMONITOR (&rest names) + "Remove the monitoring on the named functions. + Names defaults to the list of all currently monitored functions." + `(dolist (name ,(if names `',names '*monitored-functions*) (values)) + (monitoring-unencapsulate name))) + +(defun MONITOR-ALL (&optional (package *package*)) + "Monitor all functions in the specified package." + (let ((package (if (packagep package) + package + (find-package package)))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (monitoring-encapsulate symbol))))) + +(defmacro MONITOR-FORM (form + &optional (nested :exclusive) (threshold 0.01) + (key :percent-time)) + "Monitor the execution of all functions in the current package +during the execution of FORM. All functions that are executed above +THRESHOLD % will be reported." + `(unwind-protect + (progn + (monitor-all) + (reset-all-monitoring) + (prog1 + (time ,form) + (report-monitoring :all ,nested ,threshold ,key :ignore-no-calls))) + (unmonitor))) + +(defmacro WITH-MONITORING ((&rest functions) + (&optional (nested :exclusive) + (threshold 0.01) + (key :percent-time)) + &body body) + "Monitor the specified functions during the execution of the body." + `(unwind-protect + (progn + (dolist (fun ',functions) + (monitoring-encapsulate fun)) + (reset-all-monitoring) + ,@body + (report-monitoring :all ,nested ,threshold ,key)) + (unmonitor))) + +;;; ******************************** +;;; Overhead Calculations ********** +;;; ******************************** +(defconstant overhead-iterations 5000 + "Number of iterations over which the timing overhead is averaged.") + +;;; Perhaps this should return something to frustrate clever compilers. +(defun STUB-FUNCTION (x) + (declare (ignore x)) + nil) +(proclaim '(notinline stub-function)) + +(defun SET-MONITOR-OVERHEAD () + "Determines the average overhead of monitoring by monitoring the execution +of an empty function many times." + (setq *monitor-time-overhead* 0 + *monitor-cons-overhead* 0) + (stub-function nil) + (monitor stub-function) + (reset-all-monitoring) + (let ((overhead-function (symbol-function 'stub-function))) + (dotimes (x overhead-iterations) + (funcall overhead-function overhead-function))) +; (dotimes (x overhead-iterations) +; (stub-function nil)) + (let ((fiter (float overhead-iterations))) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values 'stub-function) + (declare (ignore calls nested-calls)) + (setq *monitor-time-overhead* (/ time fiter) + *monitor-cons-overhead* (/ cons fiter)))) + (unmonitor stub-function)) +(set-monitor-overhead) + +;;; ******************************** +;;; Report Data ******************** +;;; ******************************** +(defvar *monitor-results* nil + "A table of monitoring statistics is stored here.") +(defvar *no-calls* nil + "A list of monitored functions which weren't called.") +(defvar *estimated-total-overhead* 0) +;; (proclaim '(type time-type *estimated-total-overhead*)) + +(defstruct (monitoring-info + (:conc-name m-info-) + (:constructor make-monitoring-info + (name calls time cons + percent-time percent-cons + time-per-call cons-per-call))) + name + calls + time + cons + percent-time + percent-cons + time-per-call + cons-per-call) + +(defun REPORT (&key (names :all) + (nested :exclusive) + (threshold 0.01) + (sort-key :percent-time) + (ignore-no-calls nil)) + "Same as REPORT-MONITORING but with a nicer keyword interface" + (declare (type (member :function :percent-time :time :percent-cons + :cons :calls :time-per-call :cons-per-call) + sort-key) + (type (member :inclusive :exclusive) nested)) + (report-monitoring names nested threshold sort-key ignore-no-calls)) + +(defun REPORT-MONITORING (&optional names + (nested :exclusive) + (threshold 0.01) + (key :percent-time) + ignore-no-calls) + "Report the current monitoring state. +The percentage of the total time spent executing unmonitored code +in each function (:exclusive mode), or total time (:inclusive mode) +will be printed together with the number of calls and +the unmonitored time per call. Functions that have been executed +below THRESHOLD % of the time will not be reported. To report on all +functions set NAMES to be either NIL or :ALL." + (when (or (null names) (eq names :all)) (setq names *monitored-functions*)) + + (let ((total-time 0) + (total-cons 0) + (total-calls 0)) + ;; Compute overall time and consing. + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested :warn) + (declare (ignore nested-calls)) + (incf total-calls calls) + (incf total-time time) + (incf total-cons cons))) + ;; Total overhead. + (setq *estimated-total-overhead* + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second)) + ;; Assemble data for only the specified names (all monitored functions) + (if (zerop total-time) + (format *trace-output* "Not enough execution time to monitor.") + (progn + (setq *monitor-results* nil *no-calls* nil) + (dolist (name names) + (multiple-value-bind (calls nested-calls time cons) + (monitor-info-values name nested) + (declare (ignore nested-calls)) + (when (minusp time) (setq time 0.0)) + (when (minusp cons) (setq cons 0.0)) + (if (zerop calls) + (push (if (symbolp name) + (symbol-name name) + (format nil "~S" name)) + *no-calls*) + (push (make-monitoring-info + (format nil "~S" name) ; name + calls ; calls + (/ time (float time-units-per-second)) ; time in secs + (round cons) ; consing + (/ time (float total-time)) ; percent-time + (if (zerop total-cons) 0 + (/ cons (float total-cons))) ; percent-cons + (/ (/ time (float calls)) ; time-per-call + time-units-per-second) ; sec/call + (round (/ cons (float calls)))) ; cons-per-call + *monitor-results*)))) + (display-monitoring-results threshold key ignore-no-calls))))) + +(defun display-monitoring-results (&optional (threshold 0.01) + (key :percent-time) + (ignore-no-calls t)) + (let ((max-length 8) ; Function header size + (max-cons-length 8) + (total-time 0.0) + (total-consed 0) + (total-calls 0) + (total-percent-time 0) + (total-percent-cons 0)) + (sort-results key) + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (setq max-length + (max max-length + (length (m-info-name result)))) + (setq max-cons-length + (max max-cons-length + (m-info-cons-per-call result))))) + (incf max-length 2) + (setf max-cons-length (+ 2 (ceiling (log max-cons-length 10)))) + (format *trace-output* + "~%~%~ + ~VT ~VA~ + ~% ~VT % % ~VA ~ +Total Total~ + ~%Function~VT Time Cons Calls Sec/Call ~VA ~ +Time Cons~ + ~%~V,,,'-A" + max-length + max-cons-length "Cons" + max-length + max-cons-length "Per" + max-length + max-cons-length "Call" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-") + (dolist (result *monitor-results*) + (when (or (zerop threshold) + (> (m-info-percent-time result) threshold)) + (format *trace-output* + "~%~A:~VT~6,2F ~6,2F ~7D ~,6F ~VD ~8,3F ~10D" + (m-info-name result) + max-length + (* 100 (m-info-percent-time result)) + (* 100 (m-info-percent-cons result)) + (m-info-calls result) + (m-info-time-per-call result) + max-cons-length + (m-info-cons-per-call result) + (m-info-time result) + (m-info-cons result)) + (incf total-time (m-info-time result)) + (incf total-consed (m-info-cons result)) + (incf total-calls (m-info-calls result)) + (incf total-percent-time (m-info-percent-time result)) + (incf total-percent-cons (m-info-percent-cons result)))) + (format *trace-output* + "~%~V,,,'-A~ + ~%TOTAL:~VT~6,2F ~6,2F ~7D ~9@T ~VA ~8,3F ~10D~ + ~%Estimated monitoring overhead: ~5,2F seconds~ + ~%Estimated total monitoring overhead: ~5,2F seconds" + (+ max-length 62 (max 0 (- max-cons-length 5))) "-" + max-length + (* 100 total-percent-time) + (* 100 total-percent-cons) + total-calls + max-cons-length " " + total-time total-consed + (/ (* *monitor-time-overhead* total-calls) + time-units-per-second) + *estimated-total-overhead*) + (when (and (not ignore-no-calls) *no-calls*) + (setq *no-calls* (sort *no-calls* #'string<)) + (let ((num-no-calls (length *no-calls*))) + (if (> num-no-calls 20) + (format *trace-output* + "~%~@(~r~) monitored functions were not called. ~ + ~%See the variable slynk-monitor::*no-calls* for a list." + num-no-calls) + (format *trace-output* + "~%The following monitored functions were not called:~ + ~%~{~<~%~:; ~A~>~}~%" + *no-calls*)))) + (values))) + +(defun sort-results (&optional (key :percent-time)) + (setq *monitor-results* + (case key + (:function (sort *monitor-results* #'string> + :key #'m-info-name)) + ((:percent-time :time) (sort *monitor-results* #'> + :key #'m-info-time)) + ((:percent-cons :cons) (sort *monitor-results* #'> + :key #'m-info-cons)) + (:calls (sort *monitor-results* #'> + :key #'m-info-calls)) + (:time-per-call (sort *monitor-results* #'> + :key #'m-info-time-per-call)) + (:cons-per-call (sort *monitor-results* #'> + :key #'m-info-cons-per-call))))) + +;;; *END OF FILE* + + blob - /dev/null blob + d9c31c5780e19fc8834f10c73d46b0a1afd44bf0 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-apropos.lisp @@ -0,0 +1,154 @@ +(defpackage :slynk-apropos + (:use #:cl #:slynk-api) + (:export + #:apropos-list-for-emacs + #:*preferred-apropos-matcher*)) + +(in-package :slynk-apropos) + +(defparameter *preferred-apropos-matcher* 'make-cl-ppcre-matcher + "Preferred matcher for apropos searches. +Value is a function of three arguments , PATTERN, CASE-SENSITIVE and +SYMBOL-NAME-FN that should return a function, called MATCHER of one +argument, a SYMBOL. MATCHER should return non-nil if PATTERN somehow +matches the result of applying SYMBOL-NAME-FN to SYMBOL, according to +CASE-SENSITIVE. The non-nil return value can be a list of integer or +a list of lists of integers.") + +(defslyfun apropos-list-for-emacs (pattern &optional external-only + case-sensitive package) + "Make an apropos search for Emacs. +The result is a list of property lists." + (let ((package (if package + (or (parse-package package) + (error "No such package: ~S" package))))) + ;; The MAPCAN will filter all uninteresting symbols, i.e. those + ;; who cannot be meaningfully described. + ;; + ;; *BUFFER-PACKAGE* is exceptionally set so that the symbol + ;; listing will only omit package qualifier iff the user specified + ;; PACKAGE. + (let* ((*buffer-package* (or package + slynk::*slynk-io-package*)) + (matcher (funcall *preferred-apropos-matcher* + pattern + case-sensitive)) + (seen (make-hash-table)) + result) + + (do-all-symbols (sym) + (let ((external (symbol-external-p sym))) + (multiple-value-bind (bounds score) + (and + (symbol-package sym) ; see github#266 + (funcall matcher + (if package + (string sym) + (concatenate 'string + (package-name (symbol-package sym)) + (if external ":" "::") + (symbol-name sym))))) + (unless (gethash sym seen) + (when bounds + (unless (or (and external-only + (not external)) + (and package + (not (eq package (symbol-package sym))))) + (push `(,sym :bounds ,bounds + ,@(and score `(:flex-score ,score)) + :external-p ,external) + result))) + (setf (gethash sym seen) t))))) + (loop for (symbol . extra) + in (sort result + (lambda (x y) + (let ((scorex (getf (cdr x) :flex-score)) + (scorey (getf (cdr y) :flex-score))) + (if (and scorex scorey) + (> scorex scorey) + (present-symbol-before-p (car x) (car y)))))) + for short = (briefly-describe-symbol-for-emacs + symbol (getf extra :external-p)) + for score = (getf extra :flex-score) + when score + do (setf (getf extra :flex-score) + (format nil "~2$%" + (* 100 score))) + do (remf extra :external-p) + when short + collect (append short extra))))) + +(defun briefly-describe-symbol-for-emacs (symbol external-p) + "Return a property list describing SYMBOL. +Like `describe-symbol-for-emacs' but with at most one line per item." + (flet ((first-line (string) + (let ((pos (position #\newline string))) + (if (null pos) string (subseq string 0 pos))))) + (let ((desc (map-if #'stringp #'first-line + (slynk-backend:describe-symbol-for-emacs symbol)))) + (if desc + `(:designator ,(list (symbol-name symbol) + (let ((package (symbol-package symbol))) + (and package + (package-name package))) + external-p) + ,@desc + ,@(let ((arglist (and (fboundp symbol) + (slynk-backend:arglist symbol)))) + (when (and arglist + (not (eq arglist :not-available))) + `(:arglist ,(princ-to-string arglist))))))))) + +(defun present-symbol-before-p (x y) + "Return true if X belongs before Y in a printed summary of symbols. +Sorted alphabetically by package name and then symbol name, except +that symbols accessible in the current package go first." + (declare (type symbol x y)) + (flet ((accessible (s) + ;; Test breaks on NIL for package that does not inherit it + (eq (find-symbol (symbol-name s) *buffer-package*) s))) + (let ((ax (accessible x)) (ay (accessible y))) + (cond ((and ax ay) (string< (symbol-name x) (symbol-name y))) + (ax t) + (ay nil) + (t (let ((px (symbol-package x)) (py (symbol-package y))) + (if (eq px py) + (string< (symbol-name x) (symbol-name y)) + (string< (package-name px) (package-name py))))))))) + +(defun make-cl-ppcre-matcher (pattern case-sensitive) + (if (not (every #'alpha-char-p pattern)) + (cond ((find-package :cl-ppcre) + (background-message "Using CL-PPCRE for apropos on regexp \"~a\"" pattern) + + (let ((matcher (funcall (slynk-backend:find-symbol2 "cl-ppcre:create-scanner") + pattern + :case-insensitive-mode (not case-sensitive)))) + (lambda (symbol-name) + (multiple-value-bind (beg end) + (funcall (slynk-backend:find-symbol2 "cl-ppcre:scan") + matcher + symbol-name) + (when beg `((,beg ,end))))))) + (t + (background-message "Using plain apropos. Load CL-PPCRE to enable regexps") + (make-plain-matcher pattern case-sensitive))) + (make-plain-matcher pattern case-sensitive))) + +(defun make-plain-matcher (pattern case-sensitive) + (let ((chr= (if case-sensitive #'char= #'char-equal))) + (lambda (symbol-name) + (let ((beg (search pattern + symbol-name + :test chr=))) + (when beg + `((,beg ,(+ beg (length pattern))))))))) + +(defun make-flex-matcher (pattern case-sensitive) + (if (zerop (length pattern)) + (make-plain-matcher pattern case-sensitive) + (let ((chr= (if case-sensitive #'char= #'char-equal))) + (lambda (symbol-name) + (slynk-completion:flex-matches + pattern symbol-name chr=))))) + blob - /dev/null blob + 9c0f06fa39fd42ecc7060d32209714b4a1729826 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-backend.lisp @@ -0,0 +1,1684 @@ +;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*- +;;; +;;; sly-backend.lisp --- SLY backend interface. +;;; +;;; Created by James Bielman in 2003. Released into the public domain. +;;; +;;;; Frontmatter +;;; +;;; This file defines the functions that must be implemented +;;; separately for each Lisp. Each is declared as a generic function +;;; for which slynk-.lisp provides methods. + +(defpackage slynk-backend + (:use cl) + (:export *debug-slynk-backend* + sly-db-condition + compiler-condition + original-condition + message + source-context + condition + severity + with-compilation-hooks + make-location + location + location-p + location-buffer + location-position + location-hints + position-p + position-pos + print-output-to-string + quit-lisp + references + unbound-slot-filler + declaration-arglist + type-specifier-arglist + with-struct + when-let + defimplementation + converting-errors-to-error-location + make-error-location + deinit-log-output + ;; interrupt macro for the backend + *pending-sly-interrupts* + check-sly-interrupts + *interrupt-queued-handler* + ;; inspector related symbols + emacs-inspect + label-value-line + label-value-line* + with-symbol + choose-symbol + boolean-to-feature-expression + ;; package helper for backend + import-to-slynk-mop + import-slynk-mop-symbols + ;; + definterface + defimplementation + ;; auto-flush + auto-flush-loop + *auto-flush-interval* + + find-symbol2 + )) + +(defpackage slynk-mop + (:use) + (:export + ;; classes + standard-generic-function + standard-slot-definition + standard-method + standard-class + eql-specializer + eql-specializer-object + ;; standard-class readers + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-name + class-precedence-list + class-prototype + class-slots + specializer-direct-methods + ;; generic function readers + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-methods + generic-function-method-class + generic-function-method-combination + generic-function-name + ;; method readers + method-generic-function + method-function + method-lambda-list + method-specializers + method-qualifiers + ;; slot readers + slot-definition-allocation + slot-definition-documentation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-boundp-using-class + slot-value-using-class + slot-makunbound-using-class + ;; generic function protocol + compute-applicable-methods-using-classes + finalize-inheritance)) + +(in-package slynk-backend) + + +;;;; Metacode + +(defparameter *debug-slynk-backend* nil + "If this is true, backends should not catch errors but enter the +debugger where appropriate. Also, they should not perform backtrace +magic but really show every frame including SLYNK related ones.") + +(defparameter *interface-functions* '() + "The names of all interface functions.") + +(defparameter *unimplemented-interfaces* '() + "List of interface functions that are not implemented. +DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.") + +(defmacro definterface (name args documentation &rest default-body) + "Define an interface function for the backend to implement. +A function is defined with NAME, ARGS, and DOCUMENTATION. This +function first looks for a function to call in NAME's property list +that is indicated by 'IMPLEMENTATION; failing that, it looks for a +function indicated by 'DEFAULT. If neither is present, an error is +signaled. + +If a DEFAULT-BODY is supplied, then a function with the same body and +ARGS will be added to NAME's property list as the property indicated +by 'DEFAULT. + +Backends implement these functions using DEFIMPLEMENTATION." + (check-type documentation string "a documentation string") + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (labels ((gen-default-impl () + `(setf (get ',name 'default) (lambda ,args ,@default-body))) + (args-as-list (args) + (destructuring-bind (req opt key rest) (parse-lambda-list args) + `(,@req ,@opt + ,@(loop for k in key append `(,(kw k) ,k)) + ,@(or rest '(()))))) + (parse-lambda-list (args) + (parse args '(&optional &key &rest) + (make-array 4 :initial-element nil))) + (parse (args keywords vars) + (cond ((null args) + (reverse (map 'list #'reverse vars))) + ((member (car args) keywords) + (parse (cdr args) (cdr (member (car args) keywords)) vars)) + (t (push (car args) (aref vars (length keywords))) + (parse (cdr args) keywords vars)))) + (kw (s) (intern (string s) :keyword))) + `(progn + (defun ,name ,args + ,documentation + (let ((f (or (get ',name 'implementation) + (get ',name 'default)))) + (cond (f (apply f ,@(args-as-list args))) + (t (error "~S not implemented" ',name))))) + (pushnew ',name *interface-functions*) + ,(if (null default-body) + `(pushnew ',name *unimplemented-interfaces*) + (gen-default-impl)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (import ',name :slynk-backend) + (export ',name :slynk-backend)) + ',name))) + +(defmacro defimplementation (name args &body body) + (assert (every #'symbolp args) () + "Complex lambda-list not supported: ~S ~S" name args) + (let ((sym (find-symbol (symbol-name name) :slynk-backend))) + `(progn + (setf (get ',sym 'implementation) + ;; For implicit BLOCK. FLET because of interplay w/ decls. + (flet ((,sym ,args ,@body)) #',sym)) + (if (member ',sym *interface-functions*) + (setq *unimplemented-interfaces* + (remove ',sym *unimplemented-interfaces*)) + (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',sym)) + ',sym))) + +(defun warn-unimplemented-interfaces () + "Warn the user about unimplemented backend features. +The portable code calls this function at startup." + (let ((*print-pretty* t)) + (warn "These Slynk interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>" + (list (sort (copy-list *unimplemented-interfaces*) #'string<))))) + +(defun find-symbol2 (name) + ;; FIXME/TODO: Not a very good FIND-SYMBOL alternative, but works + ;; for now and localized here so we can fix that some day (adding + ;; error reporting for example). + (with-standard-io-syntax (read-from-string name))) + +(defun import-to-slynk-mop (symbol-list) + (dolist (sym symbol-list) + (let* ((slynk-mop-sym (find-symbol (symbol-name sym) :slynk-mop))) + (when slynk-mop-sym + (unintern slynk-mop-sym :slynk-mop)) + (import sym :slynk-mop) + (export sym :slynk-mop)))) + +(defun import-slynk-mop-symbols (package except) + "Import the mop symbols from PACKAGE to SLYNK-MOP. +EXCEPT is a list of symbol names which should be ignored." + (do-symbols (s :slynk-mop) + (unless (member s except :test #'string=) + (let ((real-symbol (find-symbol (string s) package))) + (assert real-symbol () "Symbol ~A not found in package ~A" s package) + (unintern s :slynk-mop) + (import real-symbol :slynk-mop) + (export real-symbol :slynk-mop))))) + +(definterface gray-package-name () + "Return a package-name that contains the Gray stream symbols. +This will be used like so: + (defpackage foo + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*)") + + +;;;; Utilities + +(defmacro with-struct ((conc-name &rest names) obj &body body) + "Like with-slots but works only for structs." + (check-type conc-name symbol) + (flet ((reader (slot) + (intern (concatenate 'string + (symbol-name conc-name) + (symbol-name slot)) + (symbol-package conc-name)))) + (let ((tmp (gensym "OO-"))) + ` (let ((,tmp ,obj)) + (symbol-macrolet + ,(loop for name in names collect + (typecase name + (symbol `(,name (,(reader name) ,tmp))) + (cons `(,(first name) (,(reader (second name)) ,tmp))) + (t (error "Malformed syntax in WITH-STRUCT: ~A" name)))) + ,@body))))) + +(defmacro when-let ((var value) &body body) + `(let ((,var ,value)) + (when ,var ,@body))) + +(defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + +(defun with-symbol (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (and (find-package package) + (find-symbol (string name) package)))) + +(defun choose-symbol (package name alt-package alt-name) + "If symbol package:name exists return that symbol, otherwise alt-package:alt-name. + Suitable for use with #." + (or (and (find-package package) + (find-symbol (string name) package)) + (find-symbol (string alt-name) alt-package))) + + +;;;; UFT8 + +(deftype octet () '(unsigned-byte 8)) +(deftype octets () '(simple-array octet (*))) + +;; Helper function. Decode the next N bytes starting from INDEX. +;; Return the decoded char and the new index. +(defun utf8-decode-aux (buffer index limit byte0 n) + (declare (type octets buffer) (fixnum index limit byte0 n)) + (if (< (- limit index) n) + (values nil index) + (do ((i 0 (1+ i)) + (code byte0 (let ((byte (aref buffer (+ index i)))) + (cond ((= (ldb (byte 2 6) byte) #b10) + (+ (ash code 6) (ldb (byte 6 0) byte))) + (t + #xFFFD))))) ;; Replacement_Character + ((= i n) + (values (cond ((<= code #xff) (code-char code)) + ((<= #xd800 code #xdfff) + (code-char #xFFFD)) ;; Replacement_Character + ((and (< code char-code-limit) + (code-char code))) + (t + (code-char #xFFFD))) ;; Replacement_Character + (+ index n)))))) + +;; Decode one character in BUFFER starting at INDEX. +;; Return 2 values: the character and the new index. +;; If there aren't enough bytes between INDEX and LIMIT return nil. +(defun utf8-decode (buffer index limit) + (declare (type octets buffer) (fixnum index limit)) + (if (= index limit) + (values nil index) + (let ((b (aref buffer index))) + (if (<= b #x7f) + (values (code-char b) (1+ index)) + (macrolet ((try (marker else) + (let* ((l (integer-length marker)) + (n (- l 2))) + `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker) + (utf8-decode-aux buffer (1+ index) limit + (ldb (byte ,(- 8 l) 0) b) + ,n) + ,else)))) + (try #b110 + (try #b1110 + (try #b11110 + (try #b111110 + (try #b1111110 + (error "Invalid encoding"))))))))))) + +;; Decode characters from BUFFER and write them to STRING. +;; Return 2 values: LASTINDEX and LASTSTART where +;; LASTINDEX is the last index in BUFFER that was not decoded +;; and LASTSTART is the last index in STRING not written. +(defun utf8-decode-into (buffer index limit string start end) + (declare (string string) (fixnum index limit start end) (type octets buffer)) + (loop + (cond ((= start end) + (return (values index start))) + (t + (multiple-value-bind (c i) (utf8-decode buffer index limit) + (cond (c + (setf (aref string start) c) + (setq index i) + (setq start (1+ start))) + (t + (return (values index start))))))))) + +(defun default-utf8-to-string (octets) + (let* ((limit (length octets)) + (str (make-string limit))) + (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit) + (if (= i limit) + (if (= limit s) + str + (adjust-array str s)) + (loop + (let ((end (+ (length str) (- limit i)))) + (setq str (adjust-array str end)) + (multiple-value-bind (i2 s2) + (utf8-decode-into octets i limit str s end) + (cond ((= i2 limit) + (return (adjust-array str s2))) + (t + (setq i i2) + (setq s s2)))))))))) + +(defmacro utf8-encode-aux (code buffer start end n) + `(cond ((< (- ,end ,start) ,n) + ,start) + (t + (setf (aref ,buffer ,start) + (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code) + (byte ,(- 7 n) 0) + ,(dpb 0 (byte 1 (- 7 n)) #xff))) + ,@(loop for i from 0 upto (- n 2) collect + `(setf (aref ,buffer (+ ,start ,(- n 1 i))) + (dpb (ldb (byte 6 ,(* 6 i)) ,code) + (byte 6 0) + #b10111111))) + (+ ,start ,n)))) + +(defun %utf8-encode (code buffer start end) + (declare (type (unsigned-byte 31) code) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (cond ((<= code #x7f) + (cond ((< start end) + (setf (aref buffer start) code) + (1+ start)) + (t start))) + ((<= code #x7ff) (utf8-encode-aux code buffer start end 2)) + ((<= #xd800 code #xdfff) + (%utf8-encode (code-char #xFFFD) ;; Replacement_Character + buffer start end)) + ((<= code #xffff) (utf8-encode-aux code buffer start end 3)) + ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4)) + ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5)) + (t (utf8-encode-aux code buffer start end 6)))) + +(defun utf8-encode (char buffer start end) + (declare (type character char) (type octets buffer) + (type (and fixnum unsigned-byte) start end)) + (%utf8-encode (char-code char) buffer start end)) + +(defun utf8-encode-into (string start end buffer index limit) + (declare (string string) (type octets buffer) (fixnum start end index limit)) + (loop + (cond ((= start end) + (return (values start index))) + ((= index limit) + (return (values start index))) + (t + (let ((i2 (utf8-encode (char string start) buffer index limit))) + (cond ((= i2 index) + (return (values start index))) + (t + (setq index i2) + (incf start)))))))) + +(defun default-string-to-utf8 (string) + (let* ((len (length string)) + (b (make-array len :element-type 'octet))) + (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len) + (if (= s len) + b + (loop + (let ((limit (+ (length b) (- len s)))) + (setq b (coerce (adjust-array b limit) 'octets)) + (multiple-value-bind (s2 i2) + (utf8-encode-into string s len b i limit) + (cond ((= s2 len) + (return (coerce (adjust-array b i2) 'octets))) + (t + (setq i i2) + (setq s s2)))))))))) + +(definterface string-to-utf8 (string) + "Convert the string STRING to a (simple-array (unsigned-byte 8))" + (default-string-to-utf8 string)) + +(definterface utf8-to-string (octets) + "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string." + (default-utf8-to-string octets)) + +;;; Codepoint length + +;; we don't need this anymore. +(definterface codepoint-length (string) + "Return the number of codepoints in STRING. +With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code +units, but other Lisps return the number of codepoints. The sly +protocol wants string lengths in terms of codepoints." + (length string)) + + +;;;; TCP server + +(definterface create-socket (host port &key backlog) + "Create a listening TCP socket on interface HOST and port PORT. +BACKLOG queue length for incoming connections.") + +(definterface local-port (socket) + "Return the local port number of SOCKET.") + +(definterface close-socket (socket) + "Close the socket SOCKET.") + +(definterface accept-connection (socket &key external-format + buffering timeout) + "Accept a client connection on the listening socket SOCKET. +Return a stream for the new connection. +If EXTERNAL-FORMAT is nil return a binary stream +otherwise create a character stream. +BUFFERING can be one of: + nil ... no buffering + t ... enable buffering + :line ... enable buffering with automatic flushing on eol.") + +(definterface add-sigio-handler (socket fn) + "Call FN whenever SOCKET is readable.") + +(definterface remove-sigio-handlers (socket) + "Remove all sigio handlers for SOCKET.") + +(definterface add-fd-handler (socket fn) + "Call FN when Lisp is waiting for input and SOCKET is readable.") + +(definterface remove-fd-handlers (socket) + "Remove all fd-handlers for SOCKET.") + +(definterface preferred-communication-style () + "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL." + nil) + +(definterface set-stream-timeout (stream timeout) + "Set the 'stream 'timeout. The timeout is either the real number + specifying the timeout in seconds or 'nil for no timeout." + (declare (ignore stream timeout)) + nil) + +;;; Base condition for networking errors. +(define-condition network-error (simple-error) ()) + +(definterface emacs-connected () + "Hook called when the first connection from Emacs is established. +Called from the INIT-FN of the socket server that accepts the +connection. + +This is intended for setting up extra context, e.g. to discover +that the calling thread is the one that interacts with Emacs." + nil) + + +;;;; Unix signals + +(defconstant +sigint+ 2) + +(definterface getpid () + "Return the (Unix) process ID of this superior Lisp.") + +(definterface install-sigint-handler (function) + "Call FUNCTION on SIGINT (instead of invoking the debugger). +Return old signal handler." + (declare (ignore function)) + nil) + +(definterface call-with-user-break-handler (handler function) + "Install the break handler HANDLER while executing FUNCTION." + (let ((old-handler (install-sigint-handler handler))) + (unwind-protect (funcall function) + (install-sigint-handler old-handler)))) + +(definterface quit-lisp () + "Exit the current lisp image.") + +(definterface lisp-implementation-type-name () + "Return a short name for the Lisp implementation." + (lisp-implementation-type)) + +(definterface lisp-implementation-program () + "Return the argv[0] of the running Lisp process, or NIL." + (let ((file (car (command-line-args)))) + (when (and file (probe-file file)) + (namestring (truename file))))) + +(definterface socket-fd (socket-stream) + "Return the file descriptor for SOCKET-STREAM.") + +(definterface make-fd-stream (fd external-format) + "Create a character stream for the file descriptor FD.") + +(definterface dup (fd) + "Duplicate a file descriptor. +If the syscall fails, signal a condition. +See dup(2).") + +(definterface exec-image (image-file args) + "Replace the current process with a new process image. +The new image is created by loading the previously dumped +core file IMAGE-FILE. +ARGS is a list of strings passed as arguments to +the new image. +This is thin wrapper around exec(3).") + +(definterface command-line-args () + "Return a list of strings as passed by the OS." + nil) + + +;; pathnames are sooo useless + +(definterface filename-to-pathname (filename) + "Return a pathname for FILENAME. +A filename in Emacs may for example contain asterisks which should not +be translated to wildcards." + (parse-namestring filename)) + +(definterface pathname-to-filename (pathname) + "Return the filename for PATHNAME." + (namestring pathname)) + +(definterface default-directory () + "Return the default directory." + (directory-namestring (truename *default-pathname-defaults*))) + +(definterface set-default-directory (directory) + "Set the default directory. +This is used to resolve filenames without directory component." + (setf *default-pathname-defaults* (truename (merge-pathnames directory))) + (default-directory)) + + +(definterface call-with-syntax-hooks (fn) + "Call FN with hooks to handle special syntax." + (funcall fn)) + +(definterface default-readtable-alist () + "Return a suitable initial value for SLYNK:*READTABLE-ALIST*." + '()) + + +;;;; Packages + +(definterface package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the +nicknames local to the designated package." + (declare (ignore package)) + nil) + +(definterface find-locally-nicknamed-package (name base-package) + "Return the package whose local nickname in BASE-PACKAGE matches NAME. +Return NIL if local nicknames are not implemented or if there is no +such package." + (cdr (assoc name (package-local-nicknames base-package) :test #'string-equal))) + + +;;;; Compilation + +(definterface call-with-compilation-hooks (func) + "Call FUNC with hooks to record compiler conditions.") + +(defmacro with-compilation-hooks ((&rest ignore) &body body) + "Execute BODY as in CALL-WITH-COMPILATION-HOOKS." + (declare (ignore ignore)) + `(call-with-compilation-hooks (lambda () (progn ,@body)))) + +(definterface slynk-compile-string (string &key buffer position filename + line column policy) + "Compile source from STRING. +During compilation, compiler conditions must be trapped and +resignalled as COMPILER-CONDITIONs. + +If supplied, BUFFER and POSITION specify the source location in Emacs. + +Additionally, if POSITION is supplied, it must be added to source +positions reported in compiler conditions. + +If FILENAME is specified it may be used by certain implementations to +rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of +source information. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +If LINE and COLUMN are supplied, and non-NIL, they may be used by +certain implementations (presumably instead of POSITION) as the line +and column of the start of the string in FILENAME. Both LINE and +COLUMN are 1-based. + +Should return T on successful compilation, NIL otherwise. +") + +(definterface slynk-compile-file (input-file output-file load-p + external-format + &key policy) + "Compile INPUT-FILE signalling COMPILE-CONDITIONs. +If LOAD-P is true, load the file after compilation. +EXTERNAL-FORMAT is a value returned by find-external-format or +:default. + +If POLICY is supplied, and non-NIL, it may be used by certain +implementations to compile with optimization qualities of its +value. + +Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p +like `compile-file'") + +(deftype severity () + '(member :error :read-error :warning :style-warning :note :redefinition)) + +;; Base condition type for compiler errors, warnings and notes. +(define-condition compiler-condition (condition) + ((original-condition + ;; The original condition thrown by the compiler if appropriate. + ;; May be NIL if a compiler does not report using conditions. + :type (or null condition) + :initarg :original-condition + :accessor original-condition) + + (severity :type severity + :initarg :severity + :accessor severity) + + (message :initarg :message + :accessor message) + + ;; Macro expansion history etc. which may be helpful in some cases + ;; but is often very verbose. + (source-context :initarg :source-context + :type (or null string) + :initform nil + :accessor source-context) + + (references :initarg :references + :initform nil + :accessor references) + + (location :initarg :location + :accessor location))) + +(definterface find-external-format (coding-system) + "Return a \"external file format designator\" for CODING-SYSTEM. +CODING-SYSTEM is Emacs-style coding system name (a string), +e.g. \"latin-1-unix\"." + (if (equal coding-system "iso-latin-1-unix") + :default + nil)) + +(definterface guess-external-format (pathname) + "Detect the external format for the file with name pathname. +Return nil if the file contains no special markers." + ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section. + (with-open-file (s pathname :if-does-not-exist nil + :external-format (or (find-external-format "latin-1-unix") + :default)) + (if s + (or (let* ((line (read-line s nil)) + (p (search "-*-" line))) + (when p + (let* ((start (+ p (length "-*-"))) + (end (search "-*-" line :start2 start))) + (when end + (%search-coding line start end))))) + (let* ((len (file-length s)) + (buf (make-string (min len 3000)))) + (file-position s (- len (length buf))) + (read-sequence buf s) + (let ((start (search "Local Variables:" buf :from-end t)) + (end (search "End:" buf :from-end t))) + (and start end (< start end) + (%search-coding buf start end)))))))) + +(defun %search-coding (str start end) + (let ((p (search "coding:" str :start2 start :end2 end))) + (when p + (incf p (length "coding:")) + (loop while (and (< p end) + (member (aref str p) '(#\space #\tab))) + do (incf p)) + (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline #\;))) + str :start p))) + (find-external-format (subseq str p end)))))) + + +;;;; Streams + +(definterface make-output-stream (write-string) + "Return a new character output stream. +The stream calls WRITE-STRING when output is ready.") + +(definterface make-input-stream (read-string) + "Return a new character input stream. +The stream calls READ-STRING when input is needed.") + +(defvar *auto-flush-interval* 0.2) + +(defun auto-flush-loop (stream interval &optional receive) + (loop + (when (not (and (open-stream-p stream) + (output-stream-p stream))) + (return nil)) + (force-output stream) + (when receive + (receive-if #'identity)) + (sleep interval))) + +(definterface make-auto-flush-thread (stream) + "Make an auto-flush thread" + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval* nil)) + :name "auto-flush-thread")) + + +;;;; Documentation + +(definterface arglist (name) + "Return the lambda list for the symbol NAME. NAME can also be +a lisp function object, on lisps which support this. + +The result can be a list or the :not-available keyword if the +arglist cannot be determined." + (declare (ignore name)) + :not-available) + +(defgeneric declaration-arglist (decl-identifier) + (:documentation + "Return the argument list of the declaration specifier belonging to the +declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined, +the keyword :NOT-AVAILABLE is returned. + +The different SLYNK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (decl-identifier) + (case decl-identifier + (dynamic-extent '(&rest variables)) + (ignore '(&rest variables)) + (ignorable '(&rest variables)) + (special '(&rest variables)) + (inline '(&rest function-names)) + (notinline '(&rest function-names)) + (declaration '(&rest names)) + (optimize '(&any compilation-speed debug safety space speed)) + (type '(type-specifier &rest args)) + (ftype '(type-specifier &rest function-names)) + (otherwise + (flet ((typespec-p (symbol) + (member :type (describe-symbol-for-emacs symbol)))) + (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier)) + '(&rest variables)) + ((and (listp decl-identifier) + (typespec-p (first decl-identifier))) + '(&rest variables)) + (t :not-available))))))) + +(defgeneric type-specifier-arglist (typespec-operator) + (:documentation + "Return the argument list of the type specifier belonging to +TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword +:NOT-AVAILABLE is returned. + +The different SLYNK backends can specialize this generic function to +include implementation-dependend declaration specifiers, or to provide +additional information on the specifiers defined in ANSI Common Lisp.") + (:method (typespec-operator) + (declare (special *type-specifier-arglists*)) ; defined at end of file. + (typecase typespec-operator + (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*)) + :not-available)) + (t :not-available)))) + +(definterface type-specifier-p (symbol) + "Determine if SYMBOL is a type-specifier." + (or (documentation symbol 'type) + (not (eq (type-specifier-arglist symbol) :not-available)))) + +(definterface function-name (function) + "Return the name of the function object FUNCTION. + +The result is either a symbol, a list, or NIL if no function name is +available." + (declare (ignore function)) + nil) + +(definterface valid-function-name-p (form) + "Is FORM syntactically valid to name a function? + If true, FBOUNDP should not signal a type-error for FORM." + (flet ((length=2 (list) + (and (not (null (cdr list))) (null (cddr list))))) + (or (symbolp form) + (and (consp form) (length=2 form) + (eq (first form) 'setf) (symbolp (second form)))))) + +(definterface macroexpand-all (form &optional env) + "Recursively expand all macros in FORM. +Return the resulting form.") + +(definterface compiler-macroexpand-1 (form &optional env) + "Call the compiler-macro for form. +If FORM is a function call for which a compiler-macro has been +defined, invoke the expander function using *macroexpand-hook* and +return the results and T. Otherwise, return the original form and +NIL." + (let ((fun (and (consp form) + (valid-function-name-p (car form)) + (compiler-macro-function (car form) env)))) + (if fun + (let ((result (funcall *macroexpand-hook* fun form env))) + (values result (not (eq result form)))) + (values form nil)))) + +(definterface compiler-macroexpand (form &optional env) + "Repetitively call `compiler-macroexpand-1'." + (labels ((frob (form expanded) + (multiple-value-bind (new-form newly-expanded) + (compiler-macroexpand-1 form env) + (if newly-expanded + (frob new-form t) + (values new-form expanded))))) + (frob form env))) + +(definterface format-string-expand (control-string) + "Expand the format string CONTROL-STRING." + (macroexpand `(formatter ,control-string))) + +(definterface describe-symbol-for-emacs (symbol) + "Return a property list describing SYMBOL. + +The property list has an entry for each interesting aspect of the +symbol. The recognised keys are: + + :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO + :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM + +The value of each property is the corresponding documentation string, +or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys +not listed here (but sly-print-apropos in Emacs must know about +them). + +Properties should be included if and only if they are applicable to +the symbol. For example, only (and all) fbound symbols should include +the :FUNCTION property. + +Example: +\(describe-symbol-for-emacs 'vector) + => (:CLASS :NOT-DOCUMENTED + :TYPE :NOT-DOCUMENTED + :FUNCTION \"Constructs a simple-vector from the given objects.\")") + +(definterface describe-definition (name type) + "Describe the definition NAME of TYPE. +TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS. + +Return a documentation string, or NIL if none is available.") + +(definterface make-apropos-matcher (pattern symbol-name-fn + &optional + case-sensitive) + "Produce unary function that looks for PATTERN in symbol names. +SYMBOL-NAME-FN must be applied to symbol-names to produce the string +where PATTERN should be searched for. CASE-SENSITIVE indicates +case-sensitivity. On a positive match, the function returned must +return non-nil values, which may be pairs of indexes to highlight in +the symbol designation's string.") + + + +;;;; Debugging + +(definterface install-debugger-globally (function) + "Install FUNCTION as the debugger for all threads/processes. This +usually involves setting *DEBUGGER-HOOK* and, if the implementation +permits, hooking into BREAK as well." + (setq *debugger-hook* function)) + +(definterface call-with-debugging-environment (debugger-loop-fn) + "Call DEBUGGER-LOOP-FN in a suitable debugging environment. + +This function is called recursively at each debug level to invoke the +debugger loop. The purpose is to setup any necessary environment for +other debugger callbacks that will be called within the debugger loop. + +For example, this is a reasonable place to compute a backtrace, switch +to safe reader/printer settings, and so on.") + +(definterface call-with-debugger-hook (hook fun) + "Call FUN and use HOOK as debugger hook. HOOK can be NIL. + +HOOK should be called for both BREAK and INVOKE-DEBUGGER." + (let ((*debugger-hook* hook)) + (funcall fun))) + +(define-condition sly-db-condition (condition) + ((original-condition + :initarg :original-condition + :accessor original-condition)) + (:report (lambda (condition stream) + (format stream "Condition in debugger code~@[: ~A~]" + (original-condition condition)))) + (:documentation + "Wrapper for conditions that should not be debugged. + +When a condition arises from the internals of the debugger, it is not +desirable to debug it -- we'd risk entering an endless loop trying to +debug the debugger! Instead, such conditions can be reported to the +user without (re)entering the debugger by wrapping them as +`sly-db-condition's.")) + +;;; The following functions in this section are supposed to be called +;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only. + +(definterface compute-backtrace (start end) + "Returns a backtrace of the condition currently being debugged, +that is an ordered list consisting of frames. ``Ordered list'' +means that an integer I can be mapped back to the i-th frame of this +backtrace. + +START and END are zero-based indices constraining the number of frames +returned. Frame zero is defined as the frame which invoked the +debugger. If END is nil, return the frames from START to the end of +the stack.") + +(definterface print-frame (frame stream) + "Print frame to stream.") + +(definterface frame-restartable-p (frame) + "Is the frame FRAME restartable?. +Return T if `restart-frame' can safely be called on the frame." + (declare (ignore frame)) + nil) + +(definterface frame-source-location (frame-number) + "Return the source location for the frame associated to FRAME-NUMBER.") + +(definterface frame-catch-tags (frame-number) + "Return a list of catch tags for being printed in a debugger stack +frame." + (declare (ignore frame-number)) + '()) + +(definterface frame-locals (frame-number) + "Return a list of ((&key NAME ID VALUE) ...) where each element of +the list represents a local variable in the stack frame associated to +FRAME-NUMBER. + +NAME, a symbol; the name of the local variable. + +ID, an integer; used as primary key for the local variable, unique +relatively to the frame under operation. + +value, an object; the value of the local variable.") + +(definterface frame-var-value (frame-number var-id) + "Return the value of the local variable associated to VAR-ID +relatively to the frame associated to FRAME-NUMBER.") + +(definterface disassemble-frame (frame-number) + "Disassemble the code for the FRAME-NUMBER. +The output should be written to standard output. +FRAME-NUMBER is a non-negative integer.") + +(definterface eval-in-frame (form frame-number) + "Evaluate a Lisp form in the lexical context of a stack frame +in the debugger. + +FRAME-NUMBER must be a positive integer with 0 indicating the +frame which invoked the debugger. + +The return value is the result of evaulating FORM in the +appropriate context.") + +(definterface frame-package (frame-number) + "Return the package corresponding to the frame at FRAME-NUMBER. +Return nil if the backend can't figure it out." + (declare (ignore frame-number)) + nil) + +(definterface frame-arguments (frame-number) + "Return the arguments passed to frame at FRAME-NUMBER as a values list. +Default values of optional arguments not passed in by the user may or +may not be returned.") + +(definterface return-from-frame (frame-number form) + "Unwind the stack to the frame FRAME-NUMBER and return the value(s) +produced by evaluating FORM in the frame context to its caller. + +Execute any clean-up code from unwind-protect forms above the frame +during unwinding. + +Return a string describing the error if it's not possible to return +from the frame.") + +(definterface restart-frame (frame-number) + "Restart execution of the frame FRAME-NUMBER with the same arguments +as it was called originally.") + +(definterface print-condition (condition stream) + "Print a condition for display in SLY-DB." + (princ condition stream)) + +(definterface condition-extras (condition) + "Return a list of extra for the debugger. +The allowed elements are of the form: + (:SHOW-FRAME-SOURCE frame-number) + (:REFERENCES &rest refs) +" + (declare (ignore condition)) + '()) + +(definterface gdb-initial-commands () + "List of gdb commands supposed to be executed first for the + ATTACH-GDB restart." + nil) + +(definterface activate-stepping (frame-number) + "Prepare the frame FRAME-NUMBER for stepping.") + +(definterface sly-db-break-on-return (frame-number) + "Set a breakpoint in the frame FRAME-NUMBER.") + +(definterface sly-db-break-at-start (symbol) + "Set a breakpoint on the beginning of the function for SYMBOL.") + +(definterface sly-db-stepper-condition-p (condition) + "Return true if SLY-DB was invoked due to a single-stepping condition, +false otherwise. " + (declare (ignore condition)) + nil) + +(definterface sly-db-step-into () + "Step into the current single-stepper form.") + +(definterface sly-db-step-next () + "Step to the next form in the current function.") + +(definterface sly-db-step-out () + "Stop single-stepping temporarily, but resume it once the current function +returns.") + + +;;;; Definition finding + +(defstruct (location (:type list) + (:constructor make-location + (buffer position &optional hints))) + (type :location) + buffer position + ;; Hints is a property list optionally containing: + ;; :snippet SOURCE-TEXT + ;; This is a snippet of the actual source text at the start of + ;; the definition, which could be used in a text search. + hints) + +(defmacro converting-errors-to-error-location (&body body) + "Catches errors during BODY and converts them to an error location." + (let ((gblock (gensym "CONVERTING-ERRORS+"))) + `(block ,gblock + (handler-bind ((error + #'(lambda (e) + (if *debug-slynk-backend* + nil ;decline + (return-from ,gblock + (make-error-location e)))))) + ,@body)))) + +(defun make-error-location (datum &rest args) + (cond ((typep datum 'condition) + `(:error ,(format nil "Error: ~A" datum))) + ((symbolp datum) + `(:error ,(format nil "Error: ~A" + (apply #'make-condition datum args)))) + (t + (assert (stringp datum)) + `(:error ,(apply #'format nil datum args))))) + +(definterface find-definitions (name) + "Return a list ((DSPEC LOCATION) ...) for NAME's definitions. + +NAME is a \"definition specifier\". + +DSPEC is a \"definition specifier\" describing the +definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or +\(DEFVAR FOO). + +LOCATION is the source location for the definition.") + +(definterface find-source-location (object) + "Returns the source location of OBJECT, or NIL. + +That is the source location of the underlying datastructure of +OBJECT. E.g. on a STANDARD-OBJECT, the source location of the +respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the +respective DEFSTRUCT definition, and so on." + ;; This returns one source location and not a list of locations. It's + ;; supposed to return the location of the DEFGENERIC definition on + ;; #'SOME-GENERIC-FUNCTION. + (declare (ignore object)) + (make-error-location "FIND-SOURCE-LOCATION is not yet implemented on ~ + this implementation.")) + +(definterface buffer-first-change (filename) + "Called for effect the first time FILENAME's buffer is modified. +CMUCL/SBCL use this to cache the unmodified file and use the +unmodified text to improve the precision of source locations." + (declare (ignore filename)) + nil) + + + +;;;; XREF + +(definterface who-calls (function-name) + "Return the call sites of FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface calls-who (function-name) + "Return the list of functions called by FUNCTION-NAME (a symbol). +The results is a list ((DSPEC LOCATION) ...)." + (declare (ignore function-name)) + :not-implemented) + +(definterface who-references (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is referenced. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-binds (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is bound. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-sets (variable-name) + "Return the locations where VARIABLE-NAME (a symbol) is set. +See WHO-CALLS for a description of the return value." + (declare (ignore variable-name)) + :not-implemented) + +(definterface who-macroexpands (macro-name) + "Return the locations where MACRO-NAME (a symbol) is expanded. +See WHO-CALLS for a description of the return value." + (declare (ignore macro-name)) + :not-implemented) + +(definterface who-specializes (class-name) + "Return the locations where CLASS-NAME (a symbol) is specialized. +See WHO-CALLS for a description of the return value." + (declare (ignore class-name)) + :not-implemented) + +;;; Simpler variants. + +(definterface list-callers (function-name) + "List the callers of FUNCTION-NAME. +This function is like WHO-CALLS except that it is expected to use +lower-level means. Whereas WHO-CALLS is usually implemented with +special compiler support, LIST-CALLERS is usually implemented by +groveling for constants in function objects throughout the heap. + +The return value is as for WHO-CALLS.") + +(definterface list-callees (function-name) + "List the functions called by FUNCTION-NAME. +See LIST-CALLERS for a description of the return value.") + + +;;;; Profiling + +;;; The following functions define a minimal profiling interface. + +(definterface profile (fname) + "Marks symbol FNAME for profiling.") + +(definterface profiled-functions () + "Returns a list of profiled functions.") + +(definterface unprofile (fname) + "Marks symbol FNAME as not profiled.") + +(definterface unprofile-all () + "Marks all currently profiled functions as not profiled." + (dolist (f (profiled-functions)) + (unprofile f))) + +(definterface profile-report () + "Prints profile report.") + +(definterface profile-reset () + "Resets profile counters.") + +(definterface profile-package (package callers-p methods) + "Wrap profiling code around all functions in PACKAGE. If a function +is already profiled, then unprofile and reprofile (useful to notice +function redefinition.) + +If CALLERS-P is T names have counts of the most common calling +functions recorded. + +When called with arguments :METHODS T, profile all methods of all +generic functions having names in the given package. Generic functions +themselves, that is, their dispatch functions, are left alone.") + + +;;;; Trace + +(definterface toggle-trace (spec) + "Toggle tracing of the function(s) given with SPEC. +SPEC can be: + (setf NAME) ; a setf function + (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method + (:defgeneric NAME) ; a generic function with all methods + (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE. + (:labels TOPLEVEL LOCAL) + (:flet TOPLEVEL LOCAL) ") + + +;;;; Inspector + +(defgeneric emacs-inspect (object) + (:documentation + "Explain to Emacs how to inspect OBJECT. + +Returns a list specifying how to render the object for inspection. + +Every element of the list must be either a string, which will be +inserted into the buffer as is, or a list of the form: + + (:value object &optional format) - Render an inspectable + object. If format is provided it must be a string and will be + rendered in place of the value, otherwise use princ-to-string. + + (:newline) - Render a \\n + + (:action label lambda &key (refresh t)) - Render LABEL (a text + string) which when clicked will call LAMBDA. If REFRESH is + non-NIL the currently inspected object will be re-inspected + after calling the lambda. +")) + +(defmethod emacs-inspect ((object t)) + "Generic method for inspecting any kind of object. + +Since we don't know how to deal with OBJECT we simply dump the +output of CL:DESCRIBE." + `("Type: " (:value ,(type-of object)) (:newline) + "Don't know how to inspect the object, dumping output of CL:DESCRIBE:" + (:newline) (:newline) + ,(with-output-to-string (desc) (describe object desc)))) + +(definterface eval-context (object) + "Return a list of bindings corresponding to OBJECT's slots." + (declare (ignore object)) + '()) + +;;; Utilities for inspector methods. +;;; + +(defun label-value-line (label value &key (newline t)) + "Create a control list which prints \"LABEL: VALUE\" in the inspector. +If NEWLINE is non-NIL a `(:newline)' is added to the result." + (list* (princ-to-string label) ": " `(:value ,value) + (if newline '((:newline)) nil))) + +(defmacro label-value-line* (&rest label-values) + ` (append ,@(loop for (label value) in label-values + collect `(label-value-line ,label ,value)))) + +(definterface describe-primitive-type (object) + "Return a string describing the primitive type of object." + (declare (ignore object)) + "N/A") + + +;;;; Multithreading +;;; +;;; The default implementations are sufficient for non-multiprocessing +;;; implementations. + +(definterface initialize-multiprocessing (continuation) + "Initialize multiprocessing, if necessary and then invoke CONTINUATION. + +Depending on the impleimentaion, this function may never return." + (funcall continuation)) + +(definterface spawn (fn &key name) + "Create a new thread to call FN.") + +(definterface thread-id (thread) + "Return an Emacs-parsable object to identify THREAD. + +Ids should be comparable with equal, i.e.: + (equal (thread-id ) (thread-id )) <==> (eq )" + thread) + +(definterface find-thread (id) + "Return the thread for ID. +ID should be an id previously obtained with THREAD-ID. +Can return nil if the thread no longer exists." + (declare (ignore id)) + (current-thread)) + +(definterface thread-name (thread) + "Return the name of THREAD. +Thread names are short strings meaningful to the user. They do not +have to be unique." + (declare (ignore thread)) + "The One True Thread") + +(definterface thread-status (thread) + "Return a string describing THREAD's state." + (declare (ignore thread)) + "") + +(definterface thread-attributes (thread) + "Return a plist of implementation-dependent attributes for THREAD" + (declare (ignore thread)) + '()) + +(definterface current-thread () + "Return the currently executing thread." + 0) + +(definterface all-threads () + "Return a fresh list of all threads." + '()) + +(definterface thread-alive-p (thread) + "Test if THREAD is termintated." + (member thread (all-threads))) + +(definterface interrupt-thread (thread fn) + "Cause THREAD to execute FN.") + +(definterface kill-thread (thread) + "Terminate THREAD immediately. +Don't execute unwind-protected sections, don't raise conditions. +(Do not pass go, do not collect $200.)" + (declare (ignore thread)) + nil) + +(definterface send (thread object) + "Send OBJECT to thread THREAD." + (declare (ignore thread)) + object) + +(definterface receive (&optional timeout) + "Return the next message from current thread's mailbox." + (receive-if (constantly t) timeout)) + +(definterface receive-if (predicate &optional timeout) + "Return the first message satisfiying PREDICATE.") + +(definterface wake-thread (thread) + "Trigger a call to CHECK-SLIME-INTERRUPTS in THREAD without using +asynchronous interrupts." + (declare (ignore thread)) + ;; Doesn't have to implement this if RECEIVE-IF periodically calls + ;; CHECK-SLIME-INTERRUPTS, but that's energy inefficient + nil) + +(definterface register-thread (name thread) + "Associate the thread THREAD with the symbol NAME. +The thread can then be retrieved with `find-registered'. +If THREAD is nil delete the association." + (declare (ignore name thread)) + nil) + +(definterface find-registered (name) + "Find the thread that was registered for the symbol NAME. +Return nil if the no thread was registred or if the tread is dead." + (declare (ignore name)) + nil) + +(definterface set-default-initial-binding (var form) + "Initialize special variable VAR by default with FORM. + +Some implementations initialize certain variables in each newly +created thread. This function sets the form which is used to produce +the initial value." + (set var (eval form))) + +;; List of delayed interrupts. +;; This should only have thread-local bindings, so no init form. +(defvar *pending-sly-interrupts*) + +(defun check-sly-interrupts () + "Execute pending interrupts if any. +This should be called periodically in operations which +can take a long time to complete. +Return a boolean indicating whether any interrupts was processed." + (when (and (boundp '*pending-sly-interrupts*) + *pending-sly-interrupts*) + (funcall (pop *pending-sly-interrupts*)) + t)) + +(defvar *interrupt-queued-handler* nil + "Function to call on queued interrupts. +Interrupts get queued when an interrupt occurs while interrupt +handling is disabled. + +Backends can use this function to abort slow operations.") + +(definterface wait-for-input (streams &optional timeout) + "Wait for input on a list of streams. Return those that are ready. +STREAMS is a list of streams +TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams +which are ready (or have reached end-of-file) without waiting. +If TIMEOUT is a number and no streams is ready after TIMEOUT seconds, +return nil. + +Return :interrupt if an interrupt occurs while waiting." + (declare (ignore streams timeout)) + ;; Invoking the slime debugger will just endlessly loop. + (call-with-debugger-hook + nil + (lambda () + (error + "~s not implemented. Check if ~s = ~s is supported by the implementation." + 'wait-for-input + (slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*") + (symbol-value + (slynk-backend:find-symbol2 "SLYNK:*COMMUNICATION-STYLE*")))))) + + +;;;; Locks + +;; Please use locks only in slynk-gray.lisp. Locks are too low-level +;; for our taste. + +(definterface make-lock (&key name) + "Make a lock for thread synchronization. +Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time +but that thread may hold it more than once." + (declare (ignore name)) + :null-lock) + +(definterface call-with-lock-held (lock function) + "Call FUNCTION with LOCK held, queueing if necessary." + (declare (ignore lock) + (type function function)) + (funcall function)) + + +;;;; Weak datastructures + +(definterface make-weak-key-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the keys." + (apply #'make-hash-table args)) + +(definterface make-weak-value-hash-table (&rest args) + "Like MAKE-HASH-TABLE, but weak w.r.t. the values." + (apply #'make-hash-table args)) + +(definterface hash-table-weakness (hashtable) + "Return nil or one of :key :value :key-or-value :key-and-value" + (declare (ignore hashtable)) + nil) + + +;;;; Floating point + +(definterface float-nan-p (float) + "Return true if FLOAT is a NaN value (Not a Number)." + ;; When the float type implements IEEE-754 floats, two NaN values + ;; are never equal; when the implementation does not support NaN, + ;; the predicate should return false. An implementation can + ;; implement comparison with "unordered-signaling predicates", which + ;; emit floating point exceptions. + (handler-case (not (= float float)) + ;; Comparisons never signal an exception other than the invalid + ;; operation exception (5.11 Details of comparison predicates). + (floating-point-invalid-operation () t))) + +(definterface float-infinity-p (float) + "Return true if FLOAT is positive or negative infinity." + (not (< most-negative-long-float + float + most-positive-long-float))) + + +;;;; Character names + +(definterface character-completion-set (prefix matchp) + "Return a list of names of characters that match PREFIX." + ;; Handle the standard and semi-standard characters. + (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout" + "Linefeed" "Return" "Backspace") + when (funcall matchp prefix name) + collect name)) + + +(defparameter *type-specifier-arglists* + '((and . (&rest type-specifiers)) + (array . (&optional element-type dimension-spec)) + (base-string . (&optional size)) + (bit-vector . (&optional size)) + (complex . (&optional type-specifier)) + (cons . (&optional car-typespec cdr-typespec)) + (double-float . (&optional lower-limit upper-limit)) + (eql . (object)) + (float . (&optional lower-limit upper-limit)) + (function . (&optional arg-typespec value-typespec)) + (integer . (&optional lower-limit upper-limit)) + (long-float . (&optional lower-limit upper-limit)) + (member . (&rest eql-objects)) + (mod . (n)) + (not . (type-specifier)) + (or . (&rest type-specifiers)) + (rational . (&optional lower-limit upper-limit)) + (real . (&optional lower-limit upper-limit)) + (satisfies . (predicate-symbol)) + (short-float . (&optional lower-limit upper-limit)) + (signed-byte . (&optional size)) + (simple-array . (&optional element-type dimension-spec)) + (simple-base-string . (&optional size)) + (simple-bit-vector . (&optional size)) + (simple-string . (&optional size)) + (single-float . (&optional lower-limit upper-limit)) + (simple-vector . (&optional size)) + (string . (&optional size)) + (unsigned-byte . (&optional size)) + (values . (&rest typespecs)) + (vector . (&optional element-type size)) + )) + +;;; Heap dumps + +(definterface save-image (filename &optional restart-function) + "Save a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded.") + +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") + +(defun deinit-log-output () + ;; Can't hang on to an fd-stream from a previous session. + (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'slynk)) + nil)) + + +;;;; Wrapping + +(definterface wrap (spec indicator &key before after replace) + "Intercept future calls to SPEC and surround them in callbacks. + +INDICATOR is a symbol identifying a particular wrapping, and is used +to differentiate between multiple wrappings. + +Implementations intercept calls to SPEC and call, in this order: + +* the BEFORE callback, if it's provided, with a single argument set to + the list of arguments passed to the intercepted call; + +* the original definition of SPEC recursively honouring any wrappings + previously established under different values of INDICATOR. If the + compatible function REPLACE is provided, call that instead. + +* the AFTER callback, if it's provided, with a single set to the list + of values returned by the previous call, or, if that call exited + non-locally, a single descriptive symbol, like :EXITED-NON-LOCALLY. + +The return value of implementation should be the +implementation-specific function object that SPEC describes, suitable +to be passed to the FIND-SOURCE-LOCATION interface." + (declare (ignore indicator)) + (assert (symbolp spec) nil + "The default implementation for WRAP allows only simple names") + (assert (null (get spec 'sly-wrap)) nil + "The default implementation for WRAP allows a single wrapping") + (let* ((saved (symbol-function spec)) + (replacement (lambda (&rest args) + (let (retlist completed) + (unwind-protect + (progn + (when before + (funcall before args)) + (setq retlist (multiple-value-list + (apply (or replace + saved) args))) + (setq completed t) + (values-list retlist)) + (when after + (funcall after (if completed + retlist + :exited-non-locally)))))))) + (setf (get spec 'sly-wrap) (list saved replacement)) + (setf (symbol-function spec) replacement) + saved)) + +(definterface unwrap (spec indicator) + "Remove from SPEC any wrappings tagged with INDICATOR." + (if (wrapped-p spec indicator) + (setf (symbol-function spec) (first (get spec 'sly-wrap))) + (cerror "All right, so I did" + "Hmmm, ~a is not correctly wrapped, you probably redefined it" + spec)) + (setf (get spec 'sly-wrap) nil) + spec) + +(definterface wrapped-p (spec indicator) + "Returns true if SPEC is wrapped with INDICATOR." + (declare (ignore indicator)) + (and (symbolp spec) + (let ((prop-value (get spec 'sly-wrap))) + (cond ((and prop-value + (not (eq (second prop-value) + (symbol-function spec)))) + (warn "~a appears to be incorrectly wrapped" spec) + nil) + (prop-value t) + (t nil))))) blob - /dev/null blob + dd5c489a445f3428250c52b4e055556730068577 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-completion.lisp @@ -0,0 +1,428 @@ +;;; slynk-flex-completion.lisp --- Common Lisp symbol completion routines +;; +;; Authors: João Távora, some parts derivative works of SLIME, by its +;; authors. +;; +(defpackage :slynk-completion + (:use #:cl #:slynk-api) + (:export + #:flex-completions + #:simple-completions + #:flex-matches)) + +;; for testing package-local nicknames +#+sbcl +(defpackage :slynk-completion-local-nicknames-test + (:use #:cl) + (:local-nicknames (#:api #:slynk-api))) + +(in-package :slynk-completion) + + +;;; Simple completion +;;; +(defslyfun simple-completions (prefix package) + "Return a list of completions for the string PREFIX." + (let ((strings (all-simple-completions prefix package))) + (list strings (longest-common-prefix strings)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'simple-completions :slynk) + (export 'simple-completions :slynk)) + +(defun all-simple-completions (prefix package) + (multiple-value-bind (name pname intern) (tokenize-symbol prefix) + (let* ((extern (and pname (not intern))) + (pkg (cond ((equal pname "") +keyword-package+) + ((not pname) (guess-buffer-package package)) + (t (guess-package pname)))) + (test (lambda (sym) (prefix-match-p name (symbol-name sym)))) + (syms (and pkg (matching-symbols pkg extern test))) + (strings (loop for sym in syms + for str = (unparse-symbol sym) + when (prefix-match-p name str) ; remove |Foo| + collect str))) + (format-completion-set strings intern pname)))) + +(defun matching-symbols (package external test) + (let ((test (if external + (lambda (s) + (and (symbol-external-p s package) + (funcall test s))) + test)) + (result '())) + (do-symbols (s package) + (when (funcall test s) + (push s result))) + (remove-duplicates result))) + +(defun unparse-symbol (symbol) + (let ((*print-case* (case (readtable-case *readtable*) + (:downcase :upcase) + (t :downcase)))) + (unparse-name (symbol-name symbol)))) + +(defun prefix-match-p (prefix string) + "Return true if PREFIX is a prefix of STRING." + (not (mismatch prefix string :end2 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun longest-common-prefix (strings) + "Return the longest string that is a common prefix of STRINGS." + (if (null strings) + "" + (flet ((common-prefix (s1 s2) + (let ((diff-pos (mismatch s1 s2))) + (if diff-pos (subseq s1 0 diff-pos) s1)))) + (reduce #'common-prefix strings)))) + +(defun format-completion-set (strings internal-p package-name) + "Format a set of completion strings. +Returns a list of completions with package qualifiers if needed." + (mapcar (lambda (string) (untokenize-symbol package-name internal-p string)) + (sort strings #'string<))) + + + + +;;; Fancy "flex" completion +;;; +(defmacro collecting ((&rest collectors) &body body) ; lifted from uiop + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + ,@body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) + +(defun to-chunks (string indexes) + "Return chunks of STRING in as specified by INDEXES." + ;; (to-chunks "farfalhini" '(1 2 3 4)) => ((1 "arfa")) + ;; (to-chunks "farfalhini" '(1 3 4)) => ((1 "a") (3 "fa")) + ;; (to-chunks "farfalhini" '(1 2 3 4 5 7 8 9)) => ((1 "arfal") (7 "ini")) + ;; (to-chunks "farfalhini" '(1 2 3 4 5 6 7 8 9)) => ((1 "arfalhini")) + (reverse (reduce (lambda (chunk-list number) + (let ((latest-chunk (car chunk-list))) + (if (and latest-chunk + (= (+ + (length (second latest-chunk)) + (first latest-chunk)) + number)) + (progn (setf (second latest-chunk) + (format nil "~a~c" (second latest-chunk) + (aref string number))) + chunk-list) + (cons (list number (format nil "~c" (aref string number))) + chunk-list)))) + indexes + :initial-value nil))) + +(defun readably-classify (sym) + (let* ((translations '((:fboundp . "fn") + (:class . "cla") + (:typespec . "type") + (:generic-function . "generic-fn") + (:macro . "macro") + (:special-operator . "special-op") + (:package . "pak") + (:boundp . "var") + (:constant . "constant"))) + (classes (slynk::classify-symbol sym)) + (classes (if (some (lambda (m) (member m classes)) '(:generic-function :macro)) + (delete :fboundp classes) + classes)) + (translated (mapcar (lambda (cla) (cdr (assoc cla translations))) + classes))) + (format nil "~{~a~^,~}" translated))) + +(defparameter *flex-score-falloff* 1.5 + "The larger the value, the more big index distances are penalized.") + +(defparameter *more-qualified-matches* t + "If non-nil, \"foo\" more likely completes to \"bar:foo\". +Specifically this assigns a \"foo\" on \"bar:foo\" a +higher-than-usual score, as if the package qualifier \"bar\" was +shorter.") + +(defun flex-score (string indexes pattern) + "Score the match of STRING as given by INDEXES. +INDEXES as calculated by FLEX-MATCHES." + (let* ((first-pattern-colon (and pattern + (position #\: pattern))) + (index-of-first-pattern-colon (and first-pattern-colon + (elt indexes first-pattern-colon))) + (first-string-colon) + (string-length (length string))) + (cond ((and first-pattern-colon + (plusp first-pattern-colon)) + ;; If the user included a colon (":") in the pattern, score + ;; the pre-colon and post-colon parts separately and add + ;; the resulting halves together. This tends to fare + ;; slightly better when matching qualified symbols. + (let ((package-designator-score + (flex-score-1 index-of-first-pattern-colon + (subseq indexes 0 first-pattern-colon))) + (symbol-name-score + (flex-score-1 (- string-length + index-of-first-pattern-colon) + (mapcar (lambda (index) + (- index index-of-first-pattern-colon)) + (subseq indexes (1+ first-pattern-colon)))))) + (+ (/ package-designator-score 2) + (/ symbol-name-score 2)))) + ((and + *more-qualified-matches* + (setf first-string-colon (position #\: string)) + (< first-string-colon + (car indexes))) + ;; If the user did not include a colon, but the string + ;; we're matching again does have that colon (we're + ;; matching a qualified name), and the position of that + ;; colon happens to be less than the first index, then act + ;; as if the pre-colon part were actually half the size of + ;; what it is. This also tends to promote qualified matches + ;; meant on the symbol-name. + (let ((adjust (truncate (/ first-string-colon 2)))) + (flex-score-1 (- string-length + adjust) + (mapcar (lambda (idx) + (- idx adjust)) + indexes)))) + (t + ;; the default: score the whole pattern on the whole + ;; string. + (flex-score-1 string-length indexes))))) + +(defun flex-score-1 (string-length indexes) + "Does the real work of FLEX-SCORE. +Given that INDEXES is a list of integer position of characters in a +string of length STRING-LENGTH, say how well these characters +represent that STRING. There is a non-linear falloff with the +distances between the indexes, according to *FLEX-SCORE-FALLOFF*. If +that value is 2, for example, the indices '(0 1 2) on a 3-long +string of is a perfect (100% match,) while '(0 2) on that same +string is a 33% match and just '(1) is a 11% match." + (float + (/ (length indexes) + (* string-length + (+ 1 (reduce #'+ + (loop for i from 0 + for (a b) on `(,-1 + ,@indexes + ,string-length) + while b + collect (expt (- b a 1) *flex-score-falloff*)))))))) + +(defun flex-matches (pattern string char-test) + "Return non-NIL if PATTERN flex-matches STRING. +In case of a match, return two values: + +A list of non-negative integers which are the indexes of the +characters in PATTERN as found consecutively in STRING. This list +measures in length the number of characters in PATTERN. + +A floating-point score. Higher scores for better matches." + (declare (optimize (speed 3) (safety 0)) + (type simple-string string) + (type simple-string pattern) + (type function char-test)) + (let* ((strlen (length string)) + (indexes (loop for char across pattern + for from = 0 then (1+ pos) + for pos = (loop for i from from below strlen + when (funcall char-test + (aref string i) char) + return i) + unless pos + return nil + collect pos))) + (values indexes + (and indexes + (flex-score string indexes pattern))))) + +(defun collect-if-matches (collector pattern string symbol) + "Make and collect a match with COLLECTOR if PATTERN matches STRING. +A match is a list (STRING SYMBOL INDEXES SCORE). +Return non-nil if match was collected, nil otherwise." + (multiple-value-bind (indexes score) + (flex-matches pattern string #'char=) + (when indexes + (funcall collector + (list string + symbol + indexes + score))))) + +(defun sort-by-score (matches) + "Sort MATCHES by SCORE, highest score first. + +Matches are produced by COLLECT-IF-MATCHES (which see)." + (sort matches #'> :key #'fourth)) + +(defun keywords-matching (pattern) + "Find keyword symbols flex-matching PATTERN. +Return an unsorted list of matches. + +Matches are produced by COLLECT-IF-MATCHES (which see)." + (collecting (collect) + (and (char= (aref pattern 0) #\:) + (do-symbols (s +keyword-package+) + (collect-if-matches #'collect pattern (concatenate 'simple-string ":" + (symbol-name s)) + s))))) + +(defun accessible-matching (pattern package) + "Find symbols flex-matching PATTERN accessible without package-qualification. +Return an unsorted list of matches. + +Matches are produced by COLLECT-IF-MATCHES (which see)." + (and (not (find #\: pattern)) + (collecting (collect) + (let ((collected (make-hash-table))) + (do-symbols (s package) + ;; XXX: since DO-SYMBOLS may visit a symbol more than + ;; once. Read similar note apropos DO-ALL-SYMBOLS in + ;; QUALIFIED-MATCHING for how we do it. + (collect-if-matches + (lambda (thing) + (unless (gethash s collected) + (setf (gethash s collected) t) + (funcall #'collect thing))) + pattern (symbol-name s) s)))))) + +(defun qualified-matching (pattern home-package) + "Find package-qualified symbols flex-matching PATTERN. +Return, as two values, a set of matches for external symbols, +package-qualified using one colon, and another one for internal +symbols, package-qualified using two colons. + +The matches in the two sets are not guaranteed to be in their final +order, i.e. they are not sorted (except for the fact that +qualifications with shorter package nicknames are tried first). + +Matches are produced by COLLECT-IF-MATCHES (which see)." + (let* ((first-colon (position #\: pattern)) + (starts-with-colon (and first-colon (zerop first-colon))) + (two-colons (and first-colon (< (1+ first-colon) (length pattern)) + (eq #\: (aref pattern (1+ first-colon)))))) + (if (and starts-with-colon + (not two-colons)) + (values nil nil) + (let* ((package-local-nicknames + (slynk-backend:package-local-nicknames home-package)) + (package-local-nicknames-by-package + (let ((ret (make-hash-table))) + (loop for (short . full) in + package-local-nicknames + do (push short (gethash (find-package full) + ret))) + ret)) + (nicknames-by-package (make-hash-table))) + (flet ((sorted-nicknames (package) + (or (gethash package nicknames-by-package) + (setf (gethash package nicknames-by-package) + (sort (append + (gethash package package-local-nicknames-by-package) + (package-nicknames package) + (list (package-name package))) + #'< + :key #'length))))) + (collecting (collect-external collect-internal) + (cond + (two-colons + (let ((collected (make-hash-table))) + (do-all-symbols (s) + (loop + with package = (symbol-package s) + for nickname in (and package ; gh#226 + (sorted-nicknames package)) + do (collect-if-matches + (lambda (thing) + ;; XXX: since DO-ALL-SYMBOLS may visit + ;; a symbol more than once, we want to + ;; avoid double collections. But + ;; instead of marking every traversed + ;; symbol in a hash table, we mark just + ;; those collected. We do pay an added + ;; price of checking matching duplicate + ;; symbols, but the much smaller hash + ;; table pays off when benchmarked, + ;; because the number of collections is + ;; generally much smaller than the + ;; total number of symbols. + (unless (gethash s collected) + (setf (gethash s collected) t) + (funcall #'collect-internal thing))) + pattern + (concatenate 'simple-string + nickname + "::" + (symbol-name s)) + s))))) + (t + (loop + with use-list = (package-use-list home-package) + for package in (remove +keyword-package+ (list-all-packages)) + for sorted-nicknames + = (and (not (eq package home-package)) + (sorted-nicknames package)) + do (when sorted-nicknames + (do-external-symbols (s package) + ;;; XXX: This condition is slightly + ;;; opinionated. It says, for example, that + ;;; you never want to complete "c:del" to + ;;; "cl:delete" or "common-lisp:delete" in + ;;; packages that use :CL (a very common + ;;; case). + (when (or first-colon + (not (member (symbol-package s) use-list))) + (loop for nickname in sorted-nicknames + do (collect-if-matches #'collect-external + pattern + (concatenate 'simple-string + nickname + ":" + (symbol-name s)) + s)))))))))))))) + +(defslyfun flex-completions (pattern package-name &key (limit 300)) + "Compute \"flex\" completions for PATTERN given current PACKAGE-NAME. +Returns a list of (COMPLETIONS NIL). COMPLETIONS is a list of +\(STRING SCORE CHUNKS CLASSIFICATION-STRING)." + (when (plusp (length pattern)) + (list (loop + with package = (guess-buffer-package package-name) + with upcasepat = (string-upcase pattern) + for (string symbol indexes score) + in + (loop with (external internal) + = (multiple-value-list (qualified-matching upcasepat package)) + for e in (append (sort-by-score + (keywords-matching upcasepat)) + (sort-by-score + (append (accessible-matching upcasepat package) + external)) + (sort-by-score + internal)) + for i upto limit + collect e) + collect + (list (if (every #'common-lisp:upper-case-p pattern) + (string-upcase string) + (string-downcase string)) + score + (to-chunks string indexes) + (readably-classify symbol))) + nil))) + +(provide :slynk/completion) blob - /dev/null blob + 43fe05bd9f3e76b0d28db1a988ca4cb1221c1156 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-gray.lisp @@ -0,0 +1,220 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +;;; +;;; slynk-gray.lisp --- Gray stream based IO redirection. +;;; +;;; Created 2003 +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(in-package slynk-backend) + +#.(progn + (defvar *gray-stream-symbols* + '(fundamental-character-output-stream + stream-write-char + stream-write-string + stream-fresh-line + stream-force-output + stream-finish-output + + fundamental-character-input-stream + stream-read-char + stream-peek-char + stream-read-line + stream-listen + stream-unread-char + stream-clear-input + stream-line-column + stream-read-char-no-hang)) + nil) + +(defpackage slynk-gray + (:use cl slynk-backend) + (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) + (:export . #.*gray-stream-symbols*)) + +(in-package slynk-gray) + +(defclass sly-output-stream (fundamental-character-output-stream) + ((output-fn :initarg :output-fn) + (buffer :initform (make-string 8000)) + (fill-pointer :initform 0) + (column :initform 0) + (lock :initform (make-lock :name "buffer write lock")) + (flush-thread :initarg :flush-thread + :initform nil + :accessor flush-thread) + (flush-scheduled :initarg :flush-scheduled + :initform nil + :accessor flush-scheduled))) + +(defun maybe-schedule-flush (stream) + (when (and (flush-thread stream) + (not (flush-scheduled stream))) + (setf (flush-scheduled stream) t) + (send (flush-thread stream) t))) + +(defmacro with-sly-output-stream (stream &body body) + `(with-slots (lock output-fn buffer fill-pointer column) ,stream + (call-with-lock-held lock (lambda () ,@body)))) + +(defmethod stream-write-char ((stream sly-output-stream) char) + (with-sly-output-stream stream + (setf (schar buffer fill-pointer) char) + (incf fill-pointer) + (incf column) + (when (char= #\newline char) + (setf column 0)) + (if (= fill-pointer (length buffer)) + (finish-output stream) + (maybe-schedule-flush stream))) + char) + +(defmethod stream-write-string ((stream sly-output-stream) string + &optional start end) + (with-sly-output-stream stream + (let* ((start (or start 0)) + (end (or end (length string))) + (len (length buffer)) + (count (- end start)) + (free (- len fill-pointer))) + (when (>= count free) + (stream-finish-output stream)) + (cond ((< count len) + (replace buffer string :start1 fill-pointer + :start2 start :end2 end) + (incf fill-pointer count) + (maybe-schedule-flush stream)) + (t + (funcall output-fn (subseq string start end)))) + (let ((last-newline (position #\newline string :from-end t + :start start :end end))) + (setf column (if last-newline + (- end last-newline 1) + (+ column count)))))) + string) + +(defmethod stream-line-column ((stream sly-output-stream)) + (with-sly-output-stream stream column)) + +(defmethod reset-stream-line-column ((stream sly-output-stream)) + (with-sly-output-stream stream (setf column 0))) + +#+sbcl +(defmethod reset-stream-line-column ((stream sb-sys:fd-stream)) + (with-slots (sb-impl::output-column) stream + (setf sb-impl::output-column 0))) + +#+cmucl +(defmethod reset-stream-line-column ((stream system:fd-stream)) + (with-slots (lisp::char-pos) stream + (setf lisp::char-pos 0))) + +(defmethod stream-finish-output ((stream sly-output-stream)) + (with-sly-output-stream stream + (unless (zerop fill-pointer) + (funcall output-fn (subseq buffer 0 fill-pointer)) + (setf fill-pointer 0)) + (setf (flush-scheduled stream) nil)) + nil) + +#+(and sbcl sb-thread) +(defmethod stream-force-output :around ((stream sly-output-stream)) + ;; Workaround for deadlocks between the world-lock and auto-flush-thread + ;; buffer write lock. + ;; + ;; Another alternative would be to grab the world-lock here, but that's less + ;; future-proof, and could introduce other lock-ordering issues in the + ;; future. + (handler-case + (sb-sys:with-deadline (:seconds 0.1) + (call-next-method)) + (sb-sys:deadline-timeout () + nil))) + +(defmethod stream-force-output ((stream sly-output-stream)) + (stream-finish-output stream)) + +(defmethod stream-fresh-line ((stream sly-output-stream)) + (with-sly-output-stream stream + (cond ((zerop column) nil) + (t (terpri stream) t)))) + +(defclass sly-input-stream (fundamental-character-input-stream) + ((input-fn :initarg :input-fn) + (buffer :initform "") (index :initform 0) + (lock :initform (make-lock :name "buffer read lock")))) + +(defmethod stream-read-char ((s sly-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index input-fn) s + (when (= index (length buffer)) + (let ((string (funcall input-fn))) + (cond ((zerop (length string)) + (return-from stream-read-char :eof)) + (t + (setf buffer string) + (setf index 0))))) + (assert (plusp (length buffer))) + (prog1 (aref buffer index) (incf index)))))) + +(defmethod stream-listen ((s sly-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (< index (length buffer)))))) + +(defmethod stream-unread-char ((s sly-input-stream) char) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (decf index) + (cond ((eql (aref buffer index) char) + (setf (aref buffer index) char)) + (t + (warn "stream-unread-char: ignoring ~S (expected ~S)" + char (aref buffer index))))))) + nil) + +(defmethod stream-clear-input ((s sly-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (setf buffer "" + index 0)))) + nil) + +(defmethod stream-line-column ((s sly-input-stream)) + nil) + +(defmethod stream-read-char-no-hang ((s sly-input-stream)) + (call-with-lock-held + (slot-value s 'lock) + (lambda () + (with-slots (buffer index) s + (when (< index (length buffer)) + (prog1 (aref buffer index) (incf index))))))) + + +;;; + +(defimplementation make-auto-flush-thread (stream) + (if (typep stream 'sly-output-stream) + (setf (flush-thread stream) + (spawn (lambda () (auto-flush-loop stream 0.08 t)) + :name "auto-flush-thread")) + (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) + :name "auto-flush-thread"))) + +(defimplementation make-output-stream (write-string) + (make-instance 'sly-output-stream :output-fn write-string)) + +(defimplementation make-input-stream (read-string) + (make-instance 'sly-input-stream :input-fn read-string)) blob - /dev/null blob + d2ffa6d16861c67a974732900130ca478a1f4f2f (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-loader.lisp @@ -0,0 +1,346 @@ +;;;; -*- indent-tabs-mode: nil -*- +;;; +;;; slynk-loader.lisp --- Compile and load the Sly backend. +;;; +;;; Created 2003, James Bielman +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +;; If you want customize the source- or fasl-directory you can set +;; slynk-loader:*source-directory* resp. slynk-loader:*fasl-directory* +;; before loading this files. +;; E.g.: +;; +;; (load ".../slynk-loader.lisp") +;; (setq slynk-loader::*fasl-directory* "/tmp/fasl/") +;; (slynk-loader:init) + +(cl:defpackage :slynk-loader + (:use :cl) + (:export #:init + #:dump-image + #:*source-directory* + #:*fasl-directory* + #:*load-path*)) + +(cl:in-package :slynk-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defvar *load-path* (list *source-directory*) + "A list of directories to search for modules.") + +(defparameter *sysdep-files* + #+cmu '(slynk-source-path-parser slynk-source-file-cache (backend cmucl)) + #+scl '(slynk-source-path-parser slynk-source-file-cache (backend scl)) + #+sbcl '(slynk-source-path-parser slynk-source-file-cache + (backend sbcl)) + #+clozure '(metering (backend ccl)) + #+lispworks '((backend lispworks)) + #+allegro '((backend allegro)) + #+clisp '(xref metering (backend clisp)) + #+armedbear '((backend abcl)) + #+cormanlisp '((backend corman)) + #+ecl '(slynk-source-path-parser slynk-source-file-cache + (backend ecl)) + #+clasp '(metering (backend clasp)) + #+mkcl '((backend mkcl))) + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :clozure :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl :mkcl :clasp)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :ppc64 :x86 :x86-64 :x86_64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa :arm :armv5l :armv6l :armv7l :arm64 :aarch64 + :pentium3 :pentium4 + :mips :mipsel + :java-1.4 :java-1.5 :java-1.6 :java-1.7)) + +(defun q (s) (read-from-string s)) + +#+ecl +(defun ecl-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (when (find-symbol "LISP-IMPLEMENTATION-VCS-ID" :ext) + (let ((vcs-id (funcall (q "ext:lisp-implementation-vcs-id")))) + (when (>= (length vcs-id) 8) + (subseq vcs-id 0 8)))))) + +#+clasp +(defun clasp-version-string () + (format nil "~A~@[-~A~]" + (lisp-implementation-version) + (core:lisp-implementation-id))) + +(defun lisp-version-string () + #+(or clozure cmu) (substitute-if #\_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+(or cormanlisp scl mkcl) (lisp-implementation-version) + #+sbcl (format nil "~a~:[~;-no-threads~]" + (lisp-implementation-version) + #+sb-thread nil + #-sb-thread t) + #+lispworks (lisp-implementation-version) + #+allegro (format nil "~@{~a~}" + excl::*common-lisp-version-number* + (if (string= 'lisp "LISP") "A" "M") ; ANSI vs MoDeRn + (if (member :smp *features*) "s" "") + (if (member :64bit *features*) "-64bit" "") + (excl:ics-target-case + (:-ics "") + (:+ics "-ics"))) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+ecl (ecl-version-string) ) + +(defun unique-dir-name () + "Return a name that can be used as a directory name that is +unique to a Lisp implementation, Lisp implementation version, +operating system, and hardware architecture." + (flet ((first-of (features) + (loop for f in features + when (find f *features*) return it)) + (maybe-warn (value fstring &rest args) + (cond (value) + (t (apply #'warn fstring args) + "unknown")))) + (let ((lisp (maybe-warn (first-of *implementation-features*) + "No implementation feature found in ~a." + *implementation-features*)) + (os (maybe-warn (first-of *os-features*) + "No os feature found in ~a." *os-features*)) + (arch (maybe-warn (first-of *architecture-features*) + "No architecture feature found in ~a." + *architecture-features*)) + (version (maybe-warn (lisp-version-string) + "Don't know how to get Lisp ~ + implementation version."))) + (format nil "~(~@{~a~^-~}~)" lisp version os arch)))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun sly-version-string () + "Return a string identifying the SLY version. +Return nil if nothing appropriate is available." + (let ((this-file #.(or *compile-file-truename* *load-truename*))) + (with-open-file (s (make-pathname :name "sly" :type "el" + :directory (butlast + (pathname-directory this-file) + 1) + :defaults this-file)) + (let ((seq (make-array 200 :element-type 'character :initial-element #\null))) + (read-sequence seq s :end 200) + (let* ((beg (search ";; Version:" seq)) + (end (position #\NewLine seq :start beg)) + (middle (position #\Space seq :from-end t :end end))) + (subseq seq (1+ middle) end)))))) + +(defun default-fasl-dir () + (merge-pathnames + (make-pathname + :directory `(:relative ".sly" "fasl" + ,@(if (sly-version-string) (list (sly-version-string))) + ,(unique-dir-name))) + (let ((uhp (user-homedir-pathname))) + (make-pathname + :directory (or (pathname-directory uhp) + '(:absolute)) + :defaults uhp)))) + +(defvar *fasl-directory* (default-fasl-dir) + "The directory where fasl files should be placed.") + +(defun binary-pathname (src-pathname binary-dir) + "Return the pathname where SRC-PATHNAME's binary should be compiled." + (let ((cfp (compile-file-pathname src-pathname))) + (merge-pathnames (make-pathname :name (pathname-name cfp) + :type (pathname-type cfp)) + binary-dir))) + +(defun handle-slynk-load-error (condition context pathname) + (fresh-line *error-output*) + (pprint-logical-block (*error-output* () :per-line-prefix ";; ") + (format *error-output* + "~%Error ~A ~A:~% ~A~%" + context pathname condition))) + +(defun compile-files (files fasl-dir load quiet) + "Compile each file in FILES if the source is newer than its +corresponding binary, or the file preceding it was recompiled. +If LOAD is true, load the fasl file." + (let ((needs-recompile nil) + (state :unknown)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-bind + ((error (lambda (c) + (ecase state + (:compile (handle-slynk-load-error c "compiling" src)) + (:load (handle-slynk-load-error c "loading" dest)) + (:unknown (handle-slynk-load-error c "???ing" src)))))) + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (ensure-directories-exist dest) + ;; need to recompile SRC, so we'll need to recompile + ;; everything after this too. + (setf needs-recompile t + state :compile) + (or (compile-file src :output-file dest :print nil + :verbose (not quiet)) + ;; An implementation may not necessarily signal a + ;; condition itself when COMPILE-FILE fails (e.g. ECL) + (error "COMPILE-FILE returned NIL."))) + (when load + (setf state :load) + (load dest :verbose (not quiet)))))))) + +#+cormanlisp +(defun compile-files (files fasl-dir load quiet) + "Corman Lisp has trouble with compiled files." + (declare (ignore fasl-dir)) + (when load + (dolist (file files) + (load file :verbose (not quiet) + (force-output))))) + +(defun ensure-list (o) + (if (listp o) o (list o))) + +(defun src-files (files src-dir) + "Return actual pathnames for each spec in FILES." + (mapcar (lambda (compound-name) + (let* ((directories (butlast compound-name)) + (name (car (last compound-name)))) + (make-pathname :name (string-downcase name) :type "lisp" + :directory (append (or (pathname-directory src-dir) + '(:relative)) + (mapcar #'string-downcase directories)) + :defaults src-dir))) + (mapcar #'ensure-list files))) + +(defvar *slynk-files* + `(slynk-backend ,@*sysdep-files* #-armedbear slynk-gray slynk-match slynk-rpc + slynk slynk-completion slynk-apropos)) + +(defun load-slynk (&key (src-dir *source-directory*) + (fasl-dir *fasl-directory*) + quiet) + (compile-files (src-files *slynk-files* src-dir) fasl-dir t quiet)) + +(defun delete-stale-contrib-fasl-files (slynk-files contrib-files fasl-dir) + (let ((newest (reduce #'max (mapcar #'file-write-date slynk-files)))) + (dolist (src contrib-files) + (let ((fasl (binary-pathname src fasl-dir))) + (when (and (probe-file fasl) + (<= (file-write-date fasl) newest)) + (delete-file fasl)))))) + +(defun loadup () + (load-slynk)) + +(defun setup () + (funcall (q "slynk::init"))) + +(defun string-starts-with (string prefix) + (string-equal string prefix :end1 (min (length string) (length prefix)))) + +(defun list-slynk-packages () + (remove-if-not (lambda (package) + (let ((name (package-name package))) + (and (string-not-equal name "slynk-loader") + (string-starts-with name "slynk")))) + (list-all-packages))) + +(defun delete-packages (packages) + (dolist (package packages) + (flet ((handle-package-error (c) + (let ((pkgs (set-difference (package-used-by-list package) + packages))) + (when pkgs + (warn "deleting ~a which is used by ~{~a~^, ~}." + package pkgs)) + (continue c)))) + (handler-bind ((package-error #'handle-package-error)) + (delete-package package))))) + +(defun init (&key delete reload (setup t) + (quiet (not *load-verbose*)) + load-contribs) + "Load SLYNK and initialize some global variables. +If DELETE is true, delete any existing SLYNK packages. +If RELOAD is true, reload SLYNK, even if the SLYNK package already exists. +If SETUP is true, load user init files and initialize some +global variabes in SLYNK." + (if load-contribs + (warn + "LOAD-CONTRIBS arg to SLYNK-LOADER:INIT is deprecated and useless")) + (when (and delete (find-package :slynk)) + (delete-packages (list-slynk-packages)) + (mapc #'delete-package '(:slynk :slynk-io-package :slynk-backend))) + (cond ((or (not (find-package :slynk)) reload) + (load-slynk :quiet quiet)) + (t + (warn "Not reloading SLYNK. Package already exists."))) + (when setup + (setup))) + +(defun dump-image (filename) + (init :setup nil) + (funcall (q "slynk-backend:save-image") filename)) + + +;;;;;; Simple *require-module* function for asdf-loader.lisp. + + +(defun module-binary-dir (src-file) + (flet ((dir-components (path) + (cdr (pathname-directory path)))) + (make-pathname :directory + (append + (pathname-directory *fasl-directory*) + (nthcdr (mismatch (dir-components *fasl-directory*) + (dir-components src-file) + :test #'equal) + (dir-components src-file)))))) + +(defun require-module (module) + (labels ((module () (string-upcase module)) + (provided () + (member (string-upcase (module)) *modules* :test #'string=))) + (unless (provided) + (let* ((src-file-name (substitute #\- #\/ (string-downcase module))) + (src-file + (some #'(lambda (dir) + (probe-file (make-pathname + :name src-file-name + :type "lisp" + :defaults dir))) + *load-path*))) + (assert src-file + nil + "Required module ~a but no source file ~a found in ~a" module + src-file-name + *load-path*) + (compile-files (list src-file) + (module-binary-dir src-file) + 'load + nil) + (assert (provided) + nil + "Compiled and loaded ~a but required module ~s was not + provided" src-file module))))) blob - /dev/null blob + d10bf093616109077b6a06a0ad7bf28167d3612a (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-match.lisp @@ -0,0 +1,246 @@ +;; +;; SELECT-MATCH macro (and IN macro) +;; +;; Copyright 1990 Stephen Adams +;; +;; You are free to copy, distribute and make derivative works of this +;; source provided that this copyright notice is displayed near the +;; beginning of the file. No liability is accepted for the +;; correctness or performance of the code. If you modify the code +;; please indicate this fact both at the place of modification and in +;; this copyright message. +;; +;; Stephen Adams +;; Department of Electronics and Computer Science +;; University of Southampton +;; SO9 5NH, UK +;; +;; sra@ecs.soton.ac.uk +;; + +;; +;; Synopsis: +;; +;; (select-match expression +;; (pattern action+)*) +;; +;; --- or --- +;; +;; (select-match expression +;; pattern => expression +;; pattern => expression +;; ...) +;; +;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) +;; | symbol ;matches anything +;; | 'anything ;must be EQUAL +;; | (pattern = pattern) ;both patterns must match +;; | (#'function pattern) ;predicate test +;; | (pattern . pattern) ;cons cell +;; + +;; Example +;; +;; (select-match item +;; (('if e1 e2 e3) 'if-then-else) ;(1) +;; ((#'oddp k) 'an-odd-integer) ;(2) +;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) +;; (other 'anything-else)) ;(4) +;; +;; Notes +;; +;; . Each pattern is tested in turn. The first match is taken. +;; +;; . If no pattern matches, an error is signalled. +;; +;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. +;; numbers, strings, characters, etc.) match things which are EQUAL. +;; +;; . Quoted patterns (which are CONSTANTP) are constants. +;; +;; . Symbols match anything. The symbol is bound to the matched item +;; for the execution of the actions. +;; For example, (SELECT-MATCH '(1 2 3) +;; (1 . X) => X) +;; returns (2 3) because X is bound to the cdr of the candidate. +;; +;; . The two pattern match (p1 = p2) can be used to name parts +;; of the matched structure. For example, (ALL = (HD . TL)) +;; matches a cons cell. ALL is bound to the cons cell, HD to its car +;; and TL to its tail. +;; +;; . A predicate test applies the predicate to the item being matched. +;; If the predicate returns NIL then the match fails. +;; If it returns truth, then the nested pattern is matched. This is +;; often just a symbol like K in the example. +;; +;; . Care should be taken with the domain values for predicate matches. +;; If, in the above eg, item is not an integer, an error would occur +;; during the test. A safer pattern would be +;; (#'integerp (#'oddp k)) +;; This would only test for oddness of the item was an integer. +;; +;; . A single symbol will match anything so it can be used as a default +;; case, like OTHER above. +;; + +(defpackage :slynk-match + (:use :cl) + (:export #:match)) + +(in-package :slynk-match) + +(defmacro match (expression &body patterns) + `(select-match ,expression ,@patterns)) + +(defmacro select-match (expression &rest patterns) + (let* ((do-let (not (atom expression))) + (key (if do-let (gensym) expression)) + (cbody (expand-select-patterns key patterns)) + (cform `(cond . ,cbody))) + (if do-let + `(let ((,key ,expression)) ,cform) + cform))) + +(defun expand-select-patterns (key patterns) + (if (eq (second patterns) '=>) + (expand-select-patterns-style-2 key patterns) + (expand-select-patterns-style-1 key patterns))) + +(defun expand-select-patterns-style-1 (key patterns) + (if (null patterns) + `((t (error "Case select pattern match failure on ~S" ,key))) + (let* ((pattern (caar patterns)) + (actions (cdar patterns)) + (rest (cdr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-1 key rest)))))) + +(defun expand-select-patterns-style-2 (key patterns) + (cond ((null patterns) + `((t (error "Case select pattern match failure on ~S" ,key)))) + (t (when (or (< (length patterns) 3) + (not (eq (second patterns) '=>))) + (error "Illegal patterns: ~S" patterns)) + (let* ((pattern (first patterns)) + (actions (list (third patterns))) + (rest (cdddr patterns)) + (test (compile-select-test key pattern)) + (bindings (compile-select-bindings key pattern actions))) + `(,(if bindings `(,test (let ,bindings . ,actions)) + `(,test . ,actions)) + . ,(unless (eq test t) + (expand-select-patterns-style-2 key rest))))))) + +(defun compile-select-test (key pattern) + (let ((tests (remove t (compile-select-tests key pattern)))) + (cond + ;; note AND does this anyway, but this allows us to tell if + ;; the pattern will always match. + ((null tests) t) + ((= (length tests) 1) (car tests)) + (t `(and . ,tests))))) + +(defun compile-select-tests (key pattern) + (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) + ((symbolp pattern) 'eq) + (t 'equal)) + ,key ,pattern))) + ((symbolp pattern) '(t)) + ((select-double-match? pattern) + (append + (compile-select-tests key (first pattern)) + (compile-select-tests key (third pattern)))) + ((select-predicate? pattern) + (append + `((,(second (first pattern)) ,key)) + (compile-select-tests key (second pattern)))) + ((consp pattern) + (append + `((consp ,key)) + (compile-select-tests (cs-car key) (car + pattern)) + (compile-select-tests (cs-cdr key) (cdr + pattern)))) + (t (error "Illegal select pattern: ~S" pattern)))) + + +(defun compile-select-bindings (key pattern action) + (cond ((constantp pattern) '()) + ((symbolp pattern) + (if (select-in-tree pattern action) + `((,pattern ,key)) + '())) + ((select-double-match? pattern) + (append + (compile-select-bindings key (first pattern) action) + (compile-select-bindings key (third pattern) action))) + ((select-predicate? pattern) + (compile-select-bindings key (second pattern) action)) + ((consp pattern) + (append + (compile-select-bindings (cs-car key) (car pattern) + action) + (compile-select-bindings (cs-cdr key) (cdr pattern) + action))))) + +(defun select-in-tree (atom tree) + (or (eq atom tree) + (if (consp tree) + (or (select-in-tree atom (car tree)) + (select-in-tree atom (cdr tree)))))) + +(defun select-double-match? (pattern) + ;; ( = ) + (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) + (null (cdddr pattern)) + (eq (second pattern) '=))) + +(defun select-predicate? (pattern) + ;; ((function ) ) + (and (consp pattern) + (consp (cdr pattern)) + (null (cddr pattern)) + (consp (first pattern)) + (consp (cdr (first pattern))) + (null (cddr (first pattern))) + (eq (caar pattern) 'function))) + +(defun cs-car (exp) + (cs-car/cdr 'car exp + '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) + (cdar . cadar) (cddr . caddr) + (caaar . caaaar) (caadr . caaadr) (cadar . caadar) + (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) + (cddar . caddar) (cdddr . cadddr)))) + +(defun cs-cdr (exp) + (cs-car/cdr 'cdr exp + '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) + (cdar . cddar) (cddr . cdddr) + (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) + (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) + (cddar . cdddar) (cdddr . cddddr)))) + +(defun cs-car/cdr (op exp table) + (if (and (consp exp) (= (length exp) 2)) + (let ((replacement (assoc (car exp) table))) + (if replacement + `(,(cdr replacement) ,(second exp)) + `(,op ,exp))) + `(,op ,exp))) + +;; (setf c1 '(select-match x (a 1) (b 2 3 4))) +;; (setf c2 '(select-match (car y) +;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ +;; else)))) +;; (setf c3 '(select-match (caddr y) +;; ((all = (x y)) (list x y all)) +;; ((a '= b) (list 'assign a b)) +;; ((#'oddp k) (1+ k))))) + + blob - /dev/null blob + b4ab93f6fd6baab3b5782cef74a7757e5f6d7277 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-rpc.lisp @@ -0,0 +1,212 @@ +;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- +;;; +;;; slynk-rpc.lisp -- Pass remote calls and responses between lisp systems. +;;; +;;; Created 2010, Terje Norderhaug +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; + +(defpackage #:slynk-rpc + (:use :cl) + (:export + #:read-message + #:read-packet + #:slynk-reader-error + #:slynk-reader-error.packet + #:slynk-reader-error.cause + #:write-message + #:*translating-swank-to-slynk*)) + +(in-package :slynk-rpc) + + +;;;;; Input + +(define-condition slynk-reader-error (reader-error) + ((packet :type string :initarg :packet + :reader slynk-reader-error.packet) + (cause :type reader-error :initarg :cause + :reader slynk-reader-error.cause))) + +(defun read-message (stream package) + (let ((packet (read-packet stream))) + (handler-case (values (read-form packet package)) + (reader-error (c) + (error 'slynk-reader-error + :packet packet :cause c))))) + +(defun read-packet (stream) + (let* ((length (parse-header stream)) + (octets (read-chunk stream length))) + (handler-case (slynk-backend:utf8-to-string octets) + (error (c) + (error 'slynk-reader-error + :packet (asciify octets) + :cause c))))) + +(defun asciify (packet) + (with-output-to-string (*standard-output*) + (loop for code across (etypecase packet + (string (map 'vector #'char-code packet)) + (vector packet)) + do (cond ((<= code #x7f) (write-char (code-char code))) + (t (format t "\\x~x" code)))))) + +(defun parse-header (stream) + (parse-integer (map 'string #'code-char (read-chunk stream 6)) + :radix 16)) + +(defun read-chunk (stream length) + (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) + (count (read-sequence buffer stream))) + (cond ((= count length) + buffer) + ((zerop count) + (error 'end-of-file :stream stream)) + (t + (error "Short read: length=~D count=~D" length count))))) + +(defparameter *translating-swank-to-slynk* t + "Set to true to ensure SWANK*::SYMBOL is interned SLYNK*::SYMBOL. +Set by default to T to ensure that bootstrapping can occur from +clients sending strings like this on the wire. + + (:EMACS-REX (SWANK:CONNECTION-INFO) NIL T 1) + +*before* the slynk-retro.lisp contrib kicks in and renames SLYNK* +packages to SWANK*. After this happens, this variable is set to NIL, +since the translation is no longer necessary. + +The user that is completely sure that Slynk will always be contacted +by SLY clients **without** the sly-retro.el contrib, can also set this +to NIL in her ~/.swankrc. Generally best left alone.") + +(defun read-form (string package) + (with-standard-io-syntax + (let ((*package* package)) + (if *translating-swank-to-slynk* + (with-input-from-string (*standard-input* string) + (translating-read)) + (read-from-string string))))) + +(defun maybe-convert-package-designator (string) + (let ((colon-pos (position #\: string)) + (search (search "SWANK" string :test #'char-equal))) + (if (and search colon-pos) + (nstring-upcase (replace string "SLYNK")) + string))) + +(defun translating-read () + "Read a form that conforms to the protocol, otherwise signal an error." + (flet ((chomp () + (loop for ch = (read-char nil t) + while (eq ch #\space) + finally (unread-char ch)))) + (chomp) + (let ((c (read-char))) + (case c + (#\" (with-output-to-string (*standard-output*) + (loop for c = (read-char) do + (case c + (#\" (return)) + (#\\ (write-char (read-char))) + (t (write-char c)))))) + (#\( + (chomp) + (loop with dotread = nil + with retval = nil + for read = (read-char) + while (case read + (#\) nil) + (#\. (setq dotread t) t) + (t (progn (unread-char read) t))) + + when (eq dotread 'should-error) + do (error 'reader-error :format-arguments "Too many things after dot") + when dotread + do (setq dotread 'should-error) + do (setq retval (nconc retval + (if dotread + (translating-read) + (list (translating-read))))) + (chomp) + finally (return retval))) + (#\' `(quote ,(translating-read))) + (t (let ((string (with-output-to-string (*standard-output*) + (loop for ch = c then (read-char nil nil) do + (case ch + ((nil) (return)) + (#\\ (write-char (read-char))) + ((#\" #\( #\space #\)) (unread-char ch)(return)) + (t (write-char ch))))))) + (read-from-string + (maybe-convert-package-designator string)))))))) + + +;;;;; Output + +(defun write-message (message package stream) + (let* ((string (prin1-to-string-for-emacs message package)) + (octets (handler-case (slynk-backend:string-to-utf8 string) + (error (c) (encoding-error c string)))) + (length (length octets))) + (write-header stream length) + (write-sequence octets stream) + (finish-output stream))) + +;; FIXME: for now just tell emacs that we and an encoding problem. +(defun encoding-error (condition string) + (slynk-backend:string-to-utf8 + (prin1-to-string-for-emacs + `(:reader-error + ,(asciify string) + ,(format nil "Error during string-to-utf8: ~a" + (or (ignore-errors (asciify (princ-to-string condition))) + (asciify (princ-to-string (type-of condition)))))) + (find-package :cl)))) + +(defun write-header (stream length) + (declare (type (unsigned-byte 24) length)) + ;;(format *trace-output* "length: ~d (#x~x)~%" length length) + (loop for c across (format nil "~6,'0x" length) + do (write-byte (char-code c) stream))) + +(defun switch-to-double-floats (x) + (typecase x + (double-float x) + (float (coerce x 'double-float)) + (null x) + (list (loop for (x . cdr) on x + collect (switch-to-double-floats x) into result + until (atom cdr) + finally (return (append result (switch-to-double-floats cdr))))) + (t x))) + +(defun prin1-to-string-for-emacs (object package) + (with-standard-io-syntax + (let ((*print-case* :downcase) + (*print-readably* nil) + (*print-pretty* nil) + (*package* package) + ;; Emacs has only double floats. + (*read-default-float-format* 'double-float)) + (prin1-to-string (switch-to-double-floats object))))) + + +#| TEST/DEMO: + +(defparameter *transport* + (with-output-to-string (out) + (write-message '(:message (hello "world")) *package* out) + (write-message '(:return 5) *package* out) + (write-message '(:emacs-rex NIL) *package* out))) + +*transport* + +(with-input-from-string (in *transport*) + (loop while (peek-char T in NIL) + collect (read-message in *package*))) + +|# blob - /dev/null blob + 4f114e0dce852ba39464028210db102ecc8d87e4 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-source-file-cache.lisp @@ -0,0 +1,134 @@ +;;;; Source-file cache +;;; +;;; To robustly find source locations in CMUCL and SBCL it's useful to +;;; have the exact source code that the loaded code was compiled from. +;;; In this source we can accurately find the right location, and from +;;; that location we can extract a "snippet" of code to show what the +;;; definition looks like. Emacs can use this snippet in a best-match +;;; search to locate the right definition, which works well even if +;;; the buffer has been modified. +;;; +;;; The idea is that if a definition previously started with +;;; `(define-foo bar' then it probably still does. +;;; +;;; Whenever we see that the file on disk has the same +;;; `file-write-date' as a location we're looking for we cache the +;;; whole file inside Lisp. That way we will still have the matching +;;; version even if the file is later modified on disk. If the file is +;;; later recompiled and reloaded then we replace our cache entry. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +(defpackage slynk-source-file-cache + (:use cl slynk-backend) + (:import-from slynk-backend + defimplementation buffer-first-change) + (:export + get-source-code + source-cache-get ;FIXME: isn't it odd that both are exported? + + *source-snippet-size* + read-snippet + read-snippet-from-string + )) + +(in-package slynk-source-file-cache) + +(defvar *cache-sourcecode* t + "When true complete source files are cached. +The cache is used to keep known good copies of the source text which +correspond to the loaded code. Finding definitions is much more +reliable when the exact source is available, so we cache it in case it +gets edited on disk later.") + +(defvar *source-file-cache* (make-hash-table :test 'equal) + "Cache of source file contents. +Maps from truename to source-cache-entry structure.") + +(defstruct (source-cache-entry + (:conc-name source-cache-entry.) + (:constructor make-source-cache-entry (text date))) + text date) + +(defimplementation buffer-first-change (filename) + "Load a file into the cache when the user modifies its buffer. +This is a win if the user then saves the file and tries to M-. into it." + (unless (source-cached-p filename) + (ignore-errors + (source-cache-get filename (file-write-date filename)))) + nil) + +(defun get-source-code (filename code-date) + "Return the source code for FILENAME as written on DATE in a string. +If the exact version cannot be found then return the current one from disk." + (or (source-cache-get filename code-date) + (read-file filename))) + +(defun source-cache-get (filename date) + "Return the source code for FILENAME as written on DATE in a string. +Return NIL if the right version cannot be found." + (when *cache-sourcecode* + (let ((entry (gethash filename *source-file-cache*))) + (cond ((and entry (equal date (source-cache-entry.date entry))) + ;; Cache hit. + (source-cache-entry.text entry)) + ((or (null entry) + (not (equal date (source-cache-entry.date entry)))) + ;; Cache miss. + (if (equal (file-write-date filename) date) + ;; File on disk has the correct version. + (let ((source (read-file filename))) + (setf (gethash filename *source-file-cache*) + (make-source-cache-entry source date)) + source) + nil)))))) + +(defun source-cached-p (filename) + "Is any version of FILENAME in the source cache?" + (if (gethash filename *source-file-cache*) t)) + +(defun read-file (filename) + "Return the entire contents of FILENAME as a string." + (with-open-file (s filename :direction :input + :external-format (or (guess-external-format filename) + (find-external-format "latin-1") + :default)) + (let* ((string (make-string (file-length s))) + (length (read-sequence string s))) + (subseq string 0 length)))) + +;;;; Snippets + +(defvar *source-snippet-size* 256 + "Maximum number of characters in a snippet of source code. +Snippets at the beginning of definitions are used to tell Emacs what +the definitions looks like, so that it can accurately find them by +text search.") + +(defun read-snippet (stream &optional position) + "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. +If POSITION is given, set the STREAM's file position first." + (when position + (file-position stream position)) + #+sbcl (skip-comments-and-whitespace stream) + (read-upto-n-chars stream *source-snippet-size*)) + +(defun read-snippet-from-string (string &optional position) + (with-input-from-string (s string) + (read-snippet s position))) + +(defun skip-comments-and-whitespace (stream) + (case (peek-char nil stream nil nil) + ((#\Space #\Tab #\Newline #\Linefeed #\Page) + (read-char stream) + (skip-comments-and-whitespace stream)) + (#\; + (read-line stream) + (skip-comments-and-whitespace stream)))) + +(defun read-upto-n-chars (stream n) + "Return a string of upto N chars from STREAM." + (let* ((string (make-string n)) + (chars (read-sequence string stream))) + (subseq string 0 chars))) blob - /dev/null blob + cf0dc391c6e43addef27bf6fa2b9a291a4fd92b3 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk-source-path-parser.lisp @@ -0,0 +1,246 @@ +;;;; Source-paths + +;;; CMUCL/SBCL use a data structure called "source-path" to locate +;;; subforms. The compiler assigns a source-path to each form in a +;;; compilation unit. Compiler notes usually contain the source-path +;;; of the error location. +;;; +;;; Compiled code objects don't contain source paths, only the +;;; "toplevel-form-number" and the (sub-) "form-number". To get from +;;; the form-number to the source-path we need the entire toplevel-form +;;; (i.e. we have to read the source code). CMUCL has already some +;;; utilities to do this translation, but we use some extended +;;; versions, because we need more exact position info. Apparently +;;; Hemlock is happy with the position of the toplevel-form; we also +;;; need the position of subforms. +;;; +;;; We use a special readtable to get the positions of the subforms. +;;; The readtable stores the start and end position for each subform in +;;; hashtable for later retrieval. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. + +;;; Taken from slynk-cmucl.lisp, by Helmut Eller + +(defpackage slynk-source-path-parser + (:use cl) + (:export + read-source-form + source-path-string-position + source-path-file-position + source-path-source-position + + sexp-in-bounds-p + sexp-ref) + (:shadow ignore-errors)) + +(in-package slynk-source-path-parser) + +;; Some test to ensure the required conformance +(let ((rt (copy-readtable nil))) + (assert (or (not (get-macro-character #\space rt)) + (nth-value 1 (get-macro-character #\space rt)))) + (assert (not (get-macro-character #\\ rt)))) + +(eval-when (:compile-toplevel) + (defmacro ignore-errors (&rest forms) + ;;`(progn . ,forms) ; for debugging + `(cl:ignore-errors . ,forms))) + +(defun make-sharpdot-reader (orig-sharpdot-reader) + (lambda (s c n) + ;; We want things like M-. to work regardless of any #.-fu in + ;; the source file that is to be visited. (For instance, when a + ;; file contains #. forms referencing constants that do not + ;; currently exist in the image.) + (ignore-errors (funcall orig-sharpdot-reader s c n)))) + +(defun make-source-recorder (fn source-map) + "Return a macro character function that does the same as FN, but +additionally stores the result together with the stream positions +before and after of calling FN in the hashtable SOURCE-MAP." + (lambda (stream char) + (let ((start (1- (file-position stream))) + (values (multiple-value-list (funcall fn stream char))) + (end (file-position stream))) + #+(or) + (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" + start values end (char-code char) char) + (when values + (destructuring-bind (&optional existing-start &rest existing-end) + (car (gethash (car values) source-map)) + ;; Some macros may return what a sub-call to another macro + ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, + ;; once from #\# and once from #\(. If the saved form + ;; is a subform, don't save it again. + (unless (and existing-start existing-end + (<= start existing-start end) + (<= start existing-end end)) + (push (cons start end) (gethash (car values) source-map))))) + (values-list values)))) + +(defun make-source-recording-readtable (readtable source-map) + (declare (type readtable readtable) (type hash-table source-map)) + "Return a source position recording copy of READTABLE. +The source locations are stored in SOURCE-MAP." + (flet ((install-special-sharpdot-reader (rt) + (let ((fun (ignore-errors + (get-dispatch-macro-character #\# #\. rt)))) + (when fun + (let ((wrapper (make-sharpdot-reader fun))) + (set-dispatch-macro-character #\# #\. wrapper rt))))) + (install-wrappers (rt) + (dotimes (code 128) + (let ((char (code-char code))) + (multiple-value-bind (fun nt) (get-macro-character char rt) + (when fun + (let ((wrapper (make-source-recorder fun source-map))) + (set-macro-character char wrapper nt rt)))))))) + (let ((rt (copy-readtable readtable))) + (install-special-sharpdot-reader rt) + (install-wrappers rt) + rt))) + +;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. +;; Should be possible as we only need the right "list structure" and +;; not the right atoms. +(defun read-and-record-source-map (stream) + "Read the next object from STREAM. +Return the object together with a hashtable that maps +subexpressions of the object to stream positions." + (let* ((source-map (make-hash-table :test #'eq)) + (*readtable* (make-source-recording-readtable *readtable* source-map)) + (*read-suppress* nil) + (start (file-position stream)) + (form (ignore-errors (read stream))) + (end (file-position stream))) + ;; ensure that at least FORM is in the source-map + (unless (gethash form source-map) + (push (cons start end) (gethash form source-map))) + (values form source-map))) + +(defun starts-with-p (string prefix) + (declare (type string string prefix)) + (not (mismatch string prefix + :end1 (min (length string) (length prefix)) + :test #'char-equal))) + +(defun extract-package (line) + (declare (type string line)) + (let ((name (cadr (read-from-string line)))) + (find-package name))) + +#+(or) +(progn + (assert (extract-package "(in-package cl)")) + (assert (extract-package "(cl:in-package cl)")) + (assert (extract-package "(in-package \"CL\")")) + (assert (extract-package "(in-package #:cl)"))) + +;; FIXME: do something cleaner than this. +(defun readtable-for-package (package) + ;; KLUDGE: due to the load order we can't reference the slynk + ;; package. + (funcall (slynk-backend:find-symbol2 "slynk::guess-buffer-readtable") + (string-upcase (package-name package)))) + +;; Search STREAM for a "(in-package ...)" form. Use that to derive +;; the values for *PACKAGE* and *READTABLE*. +;; +;; IDEA: move GUESS-READER-STATE to slynk.lisp so that all backends +;; use the same heuristic and to avoid the need to access +;; slynk::guess-buffer-readtable from here. +(defun guess-reader-state (stream) + (let* ((point (file-position stream)) + (pkg *package*)) + (file-position stream 0) + (loop for read-line = (read-line stream nil nil) + for line = (and read-line + (string-trim '(#\Space #\Tab #\Linefeed #\Page #\Return #\Rubout) + read-line)) + do + (when (not line) (return)) + (when (or (starts-with-p line "(in-package ") + (starts-with-p line "(cl:in-package ")) + (let ((p (extract-package line))) + (when p (setf pkg p))) + (return))) + (file-position stream point) + (values (readtable-for-package pkg) pkg))) + +(defun skip-whitespace (stream) + (peek-char t stream nil nil)) + +;; Skip over N toplevel forms. +(defun skip-toplevel-forms (n stream) + (let ((*read-suppress* t)) + (dotimes (i n) + (read stream)) + (skip-whitespace stream))) + +(defun read-source-form (n stream) + "Read the Nth toplevel form number with source location recording. +Return the form and the source-map." + (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) + (let (#+sbcl + (*features* (append *features* + (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl))))) + (skip-toplevel-forms n stream) + (read-and-record-source-map stream)))) + +(defun source-path-stream-position (path stream) + "Search the source-path PATH in STREAM and return its position." + (check-source-path path) + (destructuring-bind (tlf-number . path) path + (multiple-value-bind (form source-map) (read-source-form tlf-number stream) + (source-path-source-position (cons 0 path) form source-map)))) + +(defun check-source-path (path) + (unless (and (consp path) + (every #'integerp path)) + (error "The source-path ~S is not valid." path))) + +(defun source-path-string-position (path string) + (with-input-from-string (s string) + (source-path-stream-position path s))) + +(defun source-path-file-position (path filename) + ;; We go this long way round, and don't directly operate on the file + ;; stream because FILE-POSITION (used above) is not totally savy even + ;; on file character streams; on SBCL, FILE-POSITION returns the binary + ;; offset, and not the character offset---screwing up on Unicode. + (let ((toplevel-number (first path)) + (buffer)) + (with-open-file (file filename) + (skip-toplevel-forms (1+ toplevel-number) file) + (let ((endpos (file-position file))) + (setq buffer (make-array (list endpos) :element-type 'character + :initial-element #\Space)) + (assert (file-position file 0)) + (read-sequence buffer file :end endpos))) + (source-path-string-position path buffer))) + +(defgeneric sexp-in-bounds-p (sexp i) + (:method ((list list) i) + (< i (loop for e on list + count t))) + (:method ((sexp t) i) nil)) + +(defgeneric sexp-ref (sexp i) + (:method ((s list) i) (elt s i))) + +(defun source-path-source-position (path form source-map) + "Return the start position of PATH from FORM and SOURCE-MAP. All +subforms along the path are considered and the start and end position +of the deepest (i.e. smallest) possible form is returned." + ;; compute all subforms along path + (let ((forms (loop for i in path + for f = form then (if (sexp-in-bounds-p f i) + (sexp-ref f i)) + collect f))) + ;; select the first subform present in source-map + (loop for form in (nreverse forms) + for ((start . end) . rest) = (gethash form source-map) + when (and start end (not rest)) + return (return (values start end))))) blob - /dev/null blob + e9d793899cbfeacd02bb3908f4998b72b24fef3d (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk.asd @@ -0,0 +1,122 @@ +;;; -*- lisp -*- +(in-package :asdf) + +;; ASDF system definition for loading the Slynk server independently +;; of Emacs. +;; +;; Usage: +;; +;; (push #p"/path/to/this/file/" asdf:*central-registry*) +;; (asdf:load-system :slynk) +;; (slynk:create-server :port PORT) => ACTUAL-PORT +;; +;; (PORT can be zero to mean "any available port".) +;; Then the Slynk server is running on localhost:ACTUAL-PORT. You can +;; use `M-x sly-connect' to connect Emacs to it. +;; +;; This code has been placed in the Public Domain. All warranties +;; are disclaimed. + +(defsystem :slynk + :serial t + ;; See commit message and GitHub#502, GitHub#501 for the reason + ;; for this dedicated sbcl muffling. + #+sbcl + :around-compile + #+sbcl + (lambda (thunk) + (handler-bind (((and warning (not style-warning)) + (lambda (c) + (format *error-output* "~&~@<~S: ~3i~:_~A~:>~%" + (class-name (class-of c)) c) + (muffle-warning c)))) + (let ((sb-ext:*on-package-variance* '(:warn t))) + (funcall thunk)))) + :components + ((:file "slynk-match") + (:file "slynk-backend") + ;; If/when we require ASDF3, we shall use :if-feature instead + #+(or cmu sbcl scl) + (:file "slynk-source-path-parser") + #+(or cmu ecl sbcl scl) + (:file "slynk-source-file-cache") + #+clisp + (:file "xref") + #+(or clisp clozure clasp) + (:file "metering") + (:module "backend" + :serial t + :components (#+allegro + (:file "allegro") + #+armedbear + (:file "abcl") + #+clisp + (:file "clisp") + #+clozure + (:file "ccl") + #+cmu + (:file "cmucl") + #+cormanlisp + (:file "corman") + #+ecl + (:file "ecl") + #+lispworks + (:file "lispworks") + #+sbcl + (:file "sbcl") + #+clasp + (:file "clasp") + #+scl + (:file "scl") + #+mkcl + (:file "mkcl"))) + #-armedbear + (:file "slynk-gray") + (:file "slynk-rpc") + (:file "slynk") + (:file "slynk-completion") + (:file "slynk-apropos"))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :slynk)))) + (format *debug-io* "~&SLYNK's ASDF loader finished.") + (funcall (with-standard-io-syntax (read-from-string "slynk::init")))) + + +;;; Contrib systems (should probably go into their own file one day) +;;; +(defsystem :slynk/arglists + :depends-on (:slynk) + :components ((:file "../contrib/slynk-arglists"))) + +(defsystem :slynk/fancy-inspector + :depends-on (:slynk) + :components ((:file "../contrib/slynk-fancy-inspector"))) + +(defsystem :slynk/package-fu + :depends-on (:slynk) + :components ((:file "../contrib/slynk-package-fu"))) + +(defsystem :slynk/mrepl + :depends-on (:slynk) + :components ((:file "../contrib/slynk-mrepl"))) + +(defsystem :slynk/trace-dialog + :depends-on (:slynk) + :components ((:file "../contrib/slynk-trace-dialog"))) + +(defsystem :slynk/profiler + :depends-on (:slynk) + :components ((:file "../contrib/slynk-profiler"))) + +(defsystem :slynk/stickers + :depends-on (:slynk) + :components ((:file "../contrib/slynk-stickers"))) + +(defsystem :slynk/indentation + :depends-on (:slynk) + :components ((:file "../contrib/slynk-indentation"))) + +(defsystem :slynk/retro + :depends-on (:slynk) + :components ((:file "../contrib/slynk-retro"))) + blob - /dev/null blob + 705404597904489cc1dd1377c0f903bb9781c584 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/slynk.lisp @@ -0,0 +1,4234 @@ +;;;; slynk.lisp --- Server for SLY commands. +;;; +;;; This code has been placed in the Public Domain. All warranties +;;; are disclaimed. +;;; +;;; This file defines the "Slynk" TCP server for Emacs to talk to. The +;;; code in this file is purely portable Common Lisp. We do require a +;;; smattering of non-portable functions in order to write the server, +;;; so we have defined them in `slynk-backend.lisp' and implemented +;;; them separately for each Lisp implementation. These extensions are +;;; available to us here via the `SLYNK-BACKEND' package. + +(defpackage :slynk + (:use :cl :slynk-backend :slynk-match :slynk-rpc) + (:export #:startup-multiprocessing + #:start-server + #:create-server + #:stop-server + #:restart-server + #:ed-in-emacs + #:inspect-in-emacs + #:print-indentation-lossage + #:invoke-sly-debugger + #:slynk-debugger-hook + #:emacs-inspect + ;;#:inspect-slot-for-emacs + #:authenticate-client + #:*loopback-interface* + #:*buffer-readtable* + #:process-requests) + ;; These are user-configurable variables: + (:export #:*communication-style* + #:*dont-close* + #:*fasl-pathname-function* + #:*log-events* + #:*log-output* + #:*configure-emacs-indentation* + #:*readtable-alist* + #:*global-debugger* + #:*sly-db-quit-restart* + #:*backtrace-printer-bindings* + #:*default-worker-thread-bindings* + #:*macroexpand-printer-bindings* + #:*slynk-pprint-bindings* + #:*string-elision-length* + #:*inspector-verbose* + #:*require-module* + #:*eval-for-emacs-wrappers* + #:*debugger-extra-options* + ;; These are exceptions: they are defined later in + ;; slynk-mrepl.lisp + ;; + #:*globally-redirect-io* + #:*use-dedicated-output-stream* + #:*dedicated-output-stream-port* + #:*dedicated-output-stream-buffering* + ;; This is SETFable. + #:debug-on-slynk-error + ;; These are re-exported directly from the backend: + #:buffer-first-change + #:frame-source-location + #:gdb-initial-commands + #:restart-frame + #:sly-db-step + #:sly-db-break + #:sly-db-break-on-return + #:default-directory + #:set-default-directory + #:quit-lisp + #:eval-for-emacs + #:eval-in-emacs + #:y-or-n-p-in-emacs + #:*find-definitions-right-trim* + #:*find-definitions-left-trim* + #:*after-toggle-trace-hook* + #:*echo-number-alist* + #:*present-number-alist*)) + +(in-package :slynk) + + +;;;; Top-level variables, constants, macros + +(defconstant cl-package (find-package :cl) + "The COMMON-LISP package.") + +(defconstant +keyword-package+ (find-package :keyword) + "The KEYWORD package.") + +(defconstant default-server-port 4005 + "The default TCP port for the server (when started manually).") + +(defvar *slynk-debug-p* t + "When true, print extra debugging information.") + +(defvar *m-x-sly-from-emacs* nil + "Bound to non-nil in START-SERVER.") + +(defvar *backtrace-pprint-dispatch-table* + (let ((table (copy-pprint-dispatch nil))) + (flet ((print-string (stream string) + (cond (*print-escape* + (escape-string string stream + :map '((#\" . "\\\"") + (#\\ . "\\\\") + (#\newline . "\\n") + (#\return . "\\r")))) + (t (write-string string stream))))) + (set-pprint-dispatch 'string #'print-string 0 table) + table))) + +(defvar *backtrace-printer-bindings* + `((*print-pretty* . t) + (*print-readably* . nil) + (*print-level* . 4) + (*print-length* . 6) + (*print-lines* . 1) + (*print-right-margin* . 200) + (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*)) + "Pretter settings for printing backtraces.") + +(defvar *default-worker-thread-bindings* '() + "An alist to initialize dynamic variables in worker threads. +The list has the form ((VAR . VALUE) ...). Each variable VAR will be +bound to the corresponding VALUE.") + +(defun call-with-bindings (alist fun) + "Call FUN with variables bound according to ALIST. +ALIST is a list of the form ((VAR . VAL) ...)." + (if (null alist) + (funcall fun) + (let* ((rlist (reverse alist)) + (vars (mapcar #'car rlist)) + (vals (mapcar #'cdr rlist))) + (progv vars vals + (funcall fun))))) + +(defmacro with-bindings (alist &body body) + "See `call-with-bindings'. +Bindings appearing earlier in the list take priority" + `(call-with-bindings ,alist (lambda () ,@body))) + +;;; The `DEFSLYFUN' macro defines a function that Emacs can call via +;;; RPC. + +(defvar *slyfuns* (make-hash-table) + "A map of Sly functions.") + +(defmacro defslyfun (name arglist &body rest) + "A DEFUN for functions that Emacs can call by RPC." + `(progn + (defun ,name ,arglist ,@rest) + (setf (gethash ',name *slyfuns*) #',name) + ;; see + (eval-when (:compile-toplevel :load-toplevel :execute) + (export ',name (symbol-package ',name))))) + +(defun missing-arg () + "A function that the compiler knows will never to return a value. +You can use (MISSING-ARG) as the initform for defstruct slots that +must always be supplied. This way the :TYPE slot option need not +include some arbitrary initial value like NIL." + (error "A required &KEY or &OPTIONAL argument was not supplied.")) + + +;;;; Hooks +;;; +;;; We use Emacs-like `add-hook' and `run-hook' utilities to support +;;; simple indirection. The interface is more CLish than the Emacs +;;; Lisp one. + +(defmacro add-hook (place function) + "Add FUNCTION to the list of values on PLACE." + `(pushnew ,function ,place)) + +(defun run-hook (functions &rest arguments) + "Call each of FUNCTIONS with ARGUMENTS." + (dolist (function functions) + (apply function arguments))) + +(defvar *new-connection-hook* '() + "This hook is run each time a connection is established. +The connection structure is given as the argument. +Backend code should treat the connection structure as opaque.") + +(defvar *connection-closed-hook* '() + "This hook is run when a connection is closed. +The connection as passed as an argument. +Backend code should treat the connection structure as opaque.") + +(defvar *pre-reply-hook* '() + "Hook run (without arguments) immediately before replying to an RPC.") + +(defvar *after-init-hook* '() + "Hook run after user init files are loaded.") + + +;;;; Connections +;;; +;;; Connection structures represent the network connections between +;;; Emacs and Lisp. +;;; +(defstruct (connection + (:constructor %make-connection) + (:conc-name connection-) + (:print-function print-connection)) + ;; The listening socket. (usually closed) + ;; + (socket (missing-arg) :type t :read-only t) + ;; Character I/O stream of socket connection. Read-only to avoid + ;; race conditions during initialization. + ;; + (socket-io (missing-arg) :type stream :read-only t) + ;; An alist of (ID . CHANNEL) entries. Channels are good for + ;; streaming data over the wire (see their description in sly.el) + ;; + (channel-counter 0 :type number) + (channels '() :type list) + ;; A list of LISTENER objects. Each listener has a couple of streams + ;; and an environment (an alist of bindings) + ;; + (listeners '() :type list) + ;; A list of INSPECTOR objects. Each inspector has its own history + ;; of inspected objects. An inspector might also be tied to a + ;; specific thread. + ;; + (inspectors '() :type list) + ;;Cache of macro-indentation information that + ;; has been sent to Emacs. This is used for preparing deltas to + ;; update Emacs's knowledge. Maps: symbol -> + ;; indentation-specification + ;; + (indentation-cache (make-hash-table :test 'eq) :type hash-table) + ;; The list of packages represented in the cache: + ;; + (indentation-cache-packages '()) + ;; The communication style used. + ;; + (communication-style nil :type (member nil :spawn :sigio :fd-handler)) + ) + +(defun print-connection (conn stream depth) + (declare (ignore depth)) + (print-unreadable-object (conn stream :type t :identity t))) + +(defstruct (singlethreaded-connection (:include connection) + (:conc-name sconn.)) + ;; The SIGINT handler we should restore when the connection is + ;; closed. + saved-sigint-handler + ;; A queue of events. Not all events can be processed in order and + ;; we need a place to stored them. + (event-queue '() :type list) + ;; A counter that is incremented whenever an event is added to the + ;; queue. This is used to detected modifications to the event queue + ;; by interrupts. The counter wraps around. + (events-enqueued 0 :type fixnum)) + +(defstruct (multithreaded-connection (:include connection) + (:conc-name mconn.)) + ;; In multithreaded systems we delegate certain tasks to specific + ;; threads. The `reader-thread' is responsible for reading network + ;; requests from Emacs and sending them to the `control-thread'; the + ;; `control-thread' is responsible for dispatching requests to the + ;; threads that should handle them. + reader-thread + control-thread + auto-flush-thread + indentation-cache-thread + ;; List of threads that are currently processing requests. We use + ;; this to find the newest/current thread for an interrupt. In the + ;; future we may store here (thread . request-tag) pairs so that we + ;; can interrupt specific requests. + (active-threads '() :type list) + ) + +(defvar *emacs-connection* nil + "The connection to Emacs currently in use.") + +(defun make-connection (socket stream style) + (let ((conn (funcall (ecase style + (:spawn + #'make-multithreaded-connection) + ((:sigio nil :fd-handler) + #'make-singlethreaded-connection)) + :socket socket + :socket-io stream + :communication-style style))) + (run-hook *new-connection-hook* conn) + (send-to-sentinel `(:add-connection ,conn)) + conn)) + +(defslyfun ping (tag) + tag) + +(defun safe-backtrace () + (ignore-errors + (call-with-debugging-environment + (lambda () (backtrace 0 nil))))) + +(define-condition slynk-error (error) + ((backtrace :initarg :backtrace :reader slynk-error.backtrace) + (condition :initarg :condition :reader slynk-error.condition)) + (:report (lambda (c s) (princ (slynk-error.condition c) s))) + (:documentation "Condition which carries a backtrace.")) + +(defun signal-slynk-error (condition &optional (backtrace (safe-backtrace))) + (error 'slynk-error :condition condition :backtrace backtrace)) + +(defvar *debug-on-slynk-protocol-error* nil + "When non-nil invoke the system debugger on errors that were +signalled during decoding/encoding the wire protocol. Do not set this +to T unless you want to debug slynk internals.") + +(defmacro with-slynk-error-handler ((connection) &body body) + "Close the connection on internal `slynk-error's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-case + (handler-bind ((slynk-error + (lambda (condition) + (when *debug-on-slynk-protocol-error* + (invoke-default-debugger condition))))) + (progn . ,body)) + (slynk-error (condition) + (close-connection ,conn + (slynk-error.condition condition) + (slynk-error.backtrace condition))))))) + +(defmacro with-panic-handler ((connection) &body body) + "Close the connection on unhandled `serious-condition's." + (let ((conn (gensym))) + `(let ((,conn ,connection)) + (handler-bind ((serious-condition + (lambda (condition) + (close-connection ,conn condition (safe-backtrace)) + (abort condition)))) + . ,body)))) + +(add-hook *new-connection-hook* 'notify-backend-of-connection) +(defun notify-backend-of-connection (connection) + (declare (ignore connection)) + (emacs-connected)) + + +;;;; Utilities + +;; stolen from Hunchentoot +(defmacro defvar-unbound (name &optional (doc-string "")) + "Convenience macro to declare unbound special variables with a +documentation string." + `(progn + (defvar ,name) + (setf (documentation ',name 'variable) ,doc-string) + ',name)) + + +;;;;; Logging + +(defvar *slynk-io-package* + (let ((package (make-package :slynk-io-package :use '()))) + (import '(nil t quote) package) + package)) + +(defvar *log-events* nil) +(defvar *log-output* nil) ; should be nil for image dumpers + +(defun init-log-output () + (unless *log-output* + (setq *log-output* (real-output-stream *error-output*)))) + +(add-hook *after-init-hook* 'init-log-output) + +(defun real-input-stream (stream) + (typecase stream + (synonym-stream + (real-input-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-input-stream (two-way-stream-input-stream stream))) + (t stream))) + +(defun real-output-stream (stream) + (typecase stream + (synonym-stream + (real-output-stream (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (real-output-stream (two-way-stream-output-stream stream))) + (t stream))) + +(defvar *event-history* (make-array 40 :initial-element nil) + "A ring buffer to record events for better error messages.") +(defvar *event-history-index* 0) +(defvar *enable-event-history* t) + +(defun log-event (format-string &rest args) + "Write a message to *terminal-io* when *log-events* is non-nil. +Useful for low level debugging." + (with-standard-io-syntax + (let ((*print-readably* nil) + (*print-pretty* nil) + (*package* *slynk-io-package*)) + (when *enable-event-history* + (setf (aref *event-history* *event-history-index*) + (format nil "~?" format-string args)) + (setf *event-history-index* + (mod (1+ *event-history-index*) (length *event-history*)))) + (when *log-events* + (write-string (escape-non-ascii (format nil "~?" format-string args)) + *log-output*) + (force-output *log-output*))))) + +(defun event-history-to-list () + "Return the list of events (older events first)." + (let ((arr *event-history*) + (idx *event-history-index*)) + (concatenate 'list (subseq arr idx) (subseq arr 0 idx)))) + +(defun clear-event-history () + (fill *event-history* nil) + (setq *event-history-index* 0)) + +(defun dump-event-history (stream) + (dolist (e (event-history-to-list)) + (dump-event e stream))) + +(defun dump-event (event stream) + (cond ((stringp event) + (write-string (escape-non-ascii event) stream)) + ((null event)) + (t + (write-string + (escape-non-ascii (format nil "Unexpected event: ~A~%" event)) + stream)))) + +(defun escape-non-ascii (string) + "Return a string like STRING but with non-ascii chars escaped." + (cond ((ascii-string-p string) string) + (t (with-output-to-string (out) + (loop for c across string do + (cond ((ascii-char-p c) (write-char c out)) + (t (format out "\\x~4,'0X" (char-code c))))))))) + +(defun ascii-string-p (o) + (and (stringp o) + (every #'ascii-char-p o))) + +(defun ascii-char-p (c) + (<= (char-code c) 127)) + + +;;;;; Helper macros + +(defmacro destructure-case (value &body patterns) + "Dispatch VALUE to one of PATTERNS. +A cross between `case' and `destructuring-bind'. +The pattern syntax is: + ((HEAD . ARGS) . BODY) +The list of patterns is searched for a HEAD `eq' to the car of +VALUE. If one is found, the BODY is executed with ARGS bound to the +corresponding values in the CDR of VALUE." + (let ((operator (gensym "op-")) + (operands (gensym "rand-")) + (tmp (gensym "tmp-"))) + `(let* ((,tmp ,value) + (,operator (car ,tmp)) + (,operands (cdr ,tmp))) + (case ,operator + ,@(loop for (pattern . body) in patterns collect + (if (eq pattern t) + `(t ,@body) + (destructuring-bind (op &rest rands) pattern + `(,op (destructuring-bind ,rands ,operands + ,@body))))) + ,@(if (eq (caar (last patterns)) t) + '() + `((t (error "destructure-case failed: ~S" ,tmp)))))))) + + + +;;; Channels + +(defmacro channels () `(connection-channels *emacs-connection*)) +(defmacro channel-counter () `(connection-channel-counter *emacs-connection*)) + +(defclass channel () + ((id :initform (incf (channel-counter)) + :reader channel-id) + (thread :initarg :thread :initform (current-thread) + :reader channel-thread) + (name :initarg :name :initform nil))) + +(defmethod initialize-instance :after ((ch channel) &key) + ;; FIXME: slightly fugly, but I need this to be able to name the + ;; thread according to the channel's id. + ;; + (with-slots (thread) ch + (when (use-threads-p) + (setf thread (spawn-channel-thread *emacs-connection* ch))) + (slynk-backend:send thread `(:serve-channel ,ch))) + (setf (channels) (nconc (channels) (list ch)))) + +(defmethod print-object ((c channel) stream) + (print-unreadable-object (c stream :type t) + (with-slots (id name) c + (format stream "~d ~a" id name)))) + +(defmethod drop-unprocessed-events (channel) + ;; FIXME: perhaps this should incorporate most + ;; behaviour from it's :after spec currently in slynk-mrepl.lisp) + (declare (ignore channel))) + +(defun find-channel (id) + (find id (channels) :key #'channel-id)) + +(defun find-channel-thread (channel) + (channel-thread channel)) + +(defun channel-thread-id (channel) + (slynk-backend:thread-id (channel-thread channel))) + +(defmethod close-channel (channel &key) + (let ((probe (find-channel (channel-id channel)))) + (cond (probe (setf (channels) (delete probe (channels)))) + (t (error "Can't close invalid channel: ~a" channel))))) + +(defgeneric channel-send (channel selector args) + (:documentation "Send to CHANNEL the message SELECTOR with ARGS.")) + +(defmacro define-channel-method (selector (channel &rest args) &body body) + `(defmethod channel-send (,channel (selector (eql ',selector)) args) + (destructuring-bind ,args args + . ,body))) + +(define-channel-method :teardown ((c channel)) + (if (use-threads-p) + ;; eventually calls CLOSE-CHANNEL + (throw 'stop-processing 'listener-teardown) + (close-channel c))) + +(defun send-to-remote-channel (channel-id msg) + (send-to-emacs `(:channel-send ,channel-id ,msg))) + + +;;; Listeners +(defclass listener () + ((out :initarg :out :type stream :reader listener-out) + (in :initarg :in :type stream :reader listener-in) + (env))) + +(defmacro listeners () `(connection-listeners *emacs-connection*)) + +(defmethod initialize-instance :after ((l listener) &key initial-env) + (with-slots (out in env) l + (let ((io (make-two-way-stream in out))) + (setf env + (append + initial-env + `((cl:*standard-output* . ,out) + (cl:*standard-input* . ,in) + (cl:*trace-output* . ,out) + (cl:*error-output* . ,out) + (cl:*debug-io* . ,io) + (cl:*query-io* . ,io) + (cl:*terminal-io* . ,io))))) + (assert out nil "Must have an OUT stream") + (assert in nil "Must have an IN stream") + (assert env nil "Must have an ENV")) + (setf (listeners) (nconc (listeners) + (list l)))) + +(defun call-with-listener (listener fn &optional saving) + (with-slots (env) listener + (with-bindings env + (unwind-protect (funcall fn) + (when saving + (loop for binding in env + do (setf (cdr binding) (symbol-value (car binding))))))))) + +(defmacro with-listener-bindings (listener &body body) + "Execute BODY inside LISTENER's environment" + `(call-with-listener ,listener (lambda () ,@body))) + +(defmacro saving-listener-bindings (listener &body body) + "Execute BODY inside LISTENER's environment, update it afterwards." + `(call-with-listener ,listener (lambda () ,@body) 'saving)) + +(defmacro with-default-listener ((connection) &body body) + "Execute BODY with in CONNECTION's default listener." + (let ((listener-sym (gensym)) + (body-fn-sym (gensym))) + `(let ((,listener-sym (default-listener ,connection)) + (,body-fn-sym #'(lambda () ,@body))) + (if ,listener-sym + (with-listener-bindings ,listener-sym + (funcall ,body-fn-sym)) + (funcall ,body-fn-sym))))) + +(defun default-listener (connection) + (first (connection-listeners connection))) + +(defun flush-listener-streams (listener) + (with-slots (in out) listener + (force-output out) + #-armedbear + (slynk-gray::reset-stream-line-column out) + (clear-input in))) + +(defmethod close-listener (l) + (with-slots (in out) l (close in) (close out)) + (setf (listeners) (delete l (listeners)))) + + +;;;; Interrupt handling + +;; Usually we'd like to enter the debugger when an interrupt happens. +;; But for some operations, in particular send&receive, it's crucial +;; that those are not interrupted when the mailbox is in an +;; inconsistent/locked state. Obviously, if send&receive don't work we +;; can't communicate and the debugger will not work. To solve that +;; problem, we try to handle interrupts only at certain safe-points. +;; +;; Whenever an interrupt happens we call the function +;; INVOKE-OR-QUEUE-INTERRUPT. Usually this simply invokes the +;; debugger, but if interrupts are disabled the interrupt is put in a +;; queue for later processing. At safe-points, we call +;; CHECK-SLY-INTERRUPTS which looks at the queue and invokes the +;; debugger if needed. +;; +;; The queue for interrupts is stored in a thread local variable. +;; WITH-CONNECTION sets it up. WITH-SLY-INTERRUPTS allows +;; interrupts, i.e. the debugger is entered immediately. When we call +;; "user code" or non-problematic code we allow interrupts. When +;; inside WITHOUT-SLY-INTERRUPTS, interrupts are queued. When we +;; switch from "user code" to more delicate operations we need to +;; disable interrupts. In particular, interrupts should be disabled +;; for SEND and RECEIVE-IF. + +;; If true execute interrupts, otherwise queue them. +;; Note: `with-connection' binds *pending-sly-interrupts*. +(defvar *sly-interrupts-enabled*) + +(defmacro with-interrupts-enabled% (flag body) + `(progn + ,@(if flag '((check-sly-interrupts))) + (multiple-value-prog1 + (let ((*sly-interrupts-enabled* ,flag)) + ,@body) + ,@(if flag '((check-sly-interrupts)))))) + +(defmacro with-sly-interrupts (&body body) + `(with-interrupts-enabled% t ,body)) + +(defmacro without-sly-interrupts (&body body) + `(with-interrupts-enabled% nil ,body)) + +(defun queue-thread-interrupt (thread function) + (interrupt-thread thread + (lambda () + ;; safely interrupt THREAD + (when (invoke-or-queue-interrupt function) + (wake-thread thread))))) + +(defun invoke-or-queue-interrupt (function) + (log-event "invoke-or-queue-interrupt: ~a~%" function) + (cond ((not (boundp '*sly-interrupts-enabled*)) + (without-sly-interrupts + (funcall function))) + (*sly-interrupts-enabled* + (log-event "interrupts-enabled~%") + (funcall function)) + (t + (setq *pending-sly-interrupts* + (nconc *pending-sly-interrupts* + (list function))) + (cond ((cdr *pending-sly-interrupts*) + (log-event "too many queued interrupts~%") + (with-simple-restart (continue "Continue from interrupt") + (handler-bind ((serious-condition #'invoke-sly-debugger)) + (check-sly-interrupts)))) + (t + (log-event "queue-interrupt: ~a~%" function) + (when *interrupt-queued-handler* + (funcall *interrupt-queued-handler*)) + t))))) + +;; Thread local variable used for flow-control. +;; It's bound by `with-connection'. +(defvar *send-counter*) + +(defmacro with-connection ((connection) &body body) + "Execute BODY in the context of CONNECTION." + `(let ((connection ,connection) + (function (lambda () . ,body))) + (if (eq *emacs-connection* connection) + (funcall function) + (let ((*emacs-connection* connection) + (*pending-sly-interrupts* '()) + (*send-counter* 0)) + (without-sly-interrupts + (with-slynk-error-handler (connection) + (with-default-listener (connection) + (call-with-debugger-hook #'slynk-debugger-hook + function)))))))) + +(defun call-with-retry-restart (msg thunk) + (loop (with-simple-restart (retry "~a" msg) + (return (funcall thunk))))) + +(defmacro with-retry-restart ((&key (msg "Retry.")) &body body) + (check-type msg string) + `(call-with-retry-restart ,msg (lambda () ,@body))) + + +;;;;; Sentinel +;;; +;;; The sentinel thread manages some global lists. +;;; FIXME: Overdesigned? + +(defvar *connections* '() + "List of all active connections, with the most recent at the front.") + +(defvar *servers* '() + "A list ((server-socket port thread) ...) describing the listening sockets. +Used to close sockets on server shutdown or restart.") + +;; FIXME: we simply access the global variable here. We could ask the +;; sentinel thread instead but then we still have the problem that the +;; connection could be closed before we use it. +(defun default-connection () + "Return the 'default' Emacs connection. +This connection can be used to talk with Emacs when no specific +connection is in use, i.e. *EMACS-CONNECTION* is NIL. + +The default connection is defined (quite arbitrarily) as the most +recently established one." + (car *connections*)) + +(defun start-sentinel () + (unless (find-registered 'sentinel) + (let ((thread (spawn #'sentinel :name "Slynk Sentinel"))) + (register-thread 'sentinel thread)))) + +(defun sentinel () + (catch 'exit-sentinel + (loop (sentinel-serve (receive))))) + +(defun send-to-sentinel (msg) + (let ((sentinel (find-registered 'sentinel))) + (cond (sentinel (send sentinel msg)) + (t (sentinel-serve msg))))) + +(defun sentinel-serve (msg) + (destructure-case msg + ((:add-connection conn) + (push conn *connections*)) + ((:close-connection connection condition backtrace) + (close-connection% connection condition backtrace) + (sentinel-maybe-exit)) + ((:add-server socket port thread) + (push (list socket port thread) *servers*)) + ((:stop-server key port) + (sentinel-stop-server key port) + (sentinel-maybe-exit)))) + +(defun sentinel-stop-server (key value) + (let ((probe (find value *servers* :key (ecase key + (:socket #'car) + (:port #'cadr))))) + (cond (probe + (setq *servers* (delete probe *servers*)) + (destructuring-bind (socket _port thread) probe + (declare (ignore _port)) + (ignore-errors (close-socket socket)) + (when (and thread + (thread-alive-p thread) + (not (eq thread (current-thread)))) + (ignore-errors (kill-thread thread))))) + (t + (warn "No server for ~s: ~s" key value))))) + +(defun sentinel-maybe-exit () + (when (and (null *connections*) + (null *servers*) + (and (current-thread) + (eq (find-registered 'sentinel) + (current-thread)))) + (register-thread 'sentinel nil) + (throw 'exit-sentinel nil))) + + +;;;;; Misc + +(defun use-threads-p () + (eq (connection-communication-style *emacs-connection*) :spawn)) + +(defun current-thread-id () + (thread-id (current-thread))) + +(declaim (inline ensure-list)) +(defun ensure-list (thing) + (if (listp thing) thing (list thing))) + + +;;;;; Symbols + +;; FIXME: this docstring is more confusing than helpful. +(defun symbol-status (symbol &optional (package (symbol-package symbol))) + "Returns one of + + :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol, + + :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol, + + :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE, + but is not _present_ in PACKAGE, + + or NIL if SYMBOL is not _accessible_ in PACKAGE. + + +Be aware not to get confused with :INTERNAL and how \"internal +symbols\" are defined in the spec; there is a slight mismatch of +definition with the Spec and what's commonly meant when talking +about internal symbols most times. As the spec says: + + In a package P, a symbol S is + + _accessible_ if S is either _present_ in P itself or was + inherited from another package Q (which implies + that S is _external_ in Q.) + + You can check that with: (AND (SYMBOL-STATUS S P) T) + + + _present_ if either P is the /home package/ of S or S has been + imported into P or exported from P by IMPORT, or + EXPORT respectively. + + Or more simply, if S is not _inherited_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :INHERITED)))) + + + _external_ if S is going to be inherited into any package that + /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or + DEFPACKAGE. + + Note that _external_ implies _present_, since to + make a symbol _external_, you'd have to use EXPORT + which will automatically make the symbol _present_. + + You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL) + + + _internal_ if S is _accessible_ but not _external_. + + You can check that with: (LET ((STATUS (SYMBOL-STATUS S P))) + (AND STATUS + (NOT (EQ STATUS :EXTERNAL)))) + + + Notice that this is *different* to + (EQ (SYMBOL-STATUS S P) :INTERNAL) + because what the spec considers _internal_ is split up into two + explicit pieces: :INTERNAL, and :INHERITED; just as, for instance, + CL:FIND-SYMBOL does. + + The rationale is that most times when you speak about \"internal\" + symbols, you're actually not including the symbols inherited + from other packages, but only about the symbols directly specific + to the package in question. +" + (when package ; may be NIL when symbol is completely uninterned. + (check-type symbol symbol) (check-type package package) + (multiple-value-bind (present-symbol status) + (find-symbol (symbol-name symbol) package) + (and (eq symbol present-symbol) status)))) + +(defun symbol-external-p (symbol &optional (package (symbol-package symbol))) + "True if SYMBOL is external in PACKAGE. +If PACKAGE is not specified, the home package of SYMBOL is used." + (eq (symbol-status symbol package) :external)) + +(defun classify-symbol (symbol) + "Returns a list of classifiers that classify SYMBOL according to its +underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special +variable.) The list may contain the following classification +keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, +:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" + (check-type symbol symbol) + (flet ((type-specifier-p (s) + (or (documentation s 'type) + (not (eq (type-specifier-arglist s) :not-available))))) + (let (result) + (when (boundp symbol) (push (if (constantp symbol) + :constant :boundp) result)) + (when (fboundp symbol) (push :fboundp result)) + (when (type-specifier-p symbol) (push :typespec result)) + (when (find-class symbol nil) (push :class result)) + (when (macro-function symbol) (push :macro result)) + (when (special-operator-p symbol) (push :special-operator result)) + (when (find-package symbol) (push :package result)) + (when (and (fboundp symbol) + (typep (ignore-errors (fdefinition symbol)) + 'generic-function)) + (push :generic-function result)) + result))) + + +;;;; TCP Server + +(defvar *communication-style* (preferred-communication-style)) + +(defvar *dont-close* nil + "Default value of :dont-close argument to start-server and + create-server.") + +(defparameter *loopback-interface* "localhost") + +(defun start-server (port-file + &key (style *communication-style*) + (dont-close *dont-close*)) + "Start the server and write the listen port number to PORT-FILE. +This is the entry point for Emacs." + (setq *m-x-sly-from-emacs* t) + (setup-server 0 + (lambda (port) (announce-server-port port-file port)) + style dont-close nil)) + +(defun create-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*) + interface + backlog) + "Start a SLYNK server on PORT running in STYLE. +If DONT-CLOSE is true then the listen socket will accept multiple +connections, otherwise it will be closed after the first. + +Optionally, an INTERFACE could be specified and swank will bind +the PORT on this interface. By default, interface is \"localhost\"." + (let ((*loopback-interface* (or interface + *loopback-interface*))) + (setup-server port #'simple-announce-function + style dont-close backlog))) + +(defun find-external-format-or-lose (coding-system) + (or (find-external-format coding-system) + (error "Unsupported coding system: ~s" coding-system))) + +(defmacro restart-loop (form &body clauses) + "Executes FORM, with restart-case CLAUSES which have a chance to modify FORM's +environment before trying again (by returning normally) or giving up (through an +explicit transfer of control), all within an implicit block named nil. +e.g.: (restart-loop (http-request url) (use-value (new) (setq url new)))" + `(loop (restart-case (return ,form) ,@clauses))) + +(defun socket-quest (port backlog) + "Attempt o create a socket on PORT. +Add a restart, prompting user to enter a new port if PORT is already +taken." + (restart-loop (create-socket *loopback-interface* port :backlog backlog) + (use-value (&optional (new-port (1+ port))) + :report (lambda (stream) (format stream "Try a port other than ~D" port)) + :interactive + (lambda () + (format *query-io* "Enter port (defaults to ~D): " (1+ port)) + (finish-output *query-io*) ; necessary for tunnels + (ignore-errors (list (parse-integer (read-line *query-io*))))) + (setq port new-port)))) + +(defun setup-server (port announce-fn style dont-close backlog) + (init-log-output) + (let* ((socket (socket-quest port backlog)) + (port (local-port socket))) + (funcall announce-fn port) + (labels ((serve () (accept-connections socket style dont-close)) + (note () (send-to-sentinel `(:add-server ,socket ,port + ,(current-thread)))) + (serve-loop () (note) (loop do (serve) while dont-close))) + (ecase style + (:spawn (initialize-multiprocessing + (lambda () + (start-sentinel) + (spawn #'serve-loop :name (format nil "Slynk ~s" port))))) + ((:fd-handler :sigio) + (note) + (add-fd-handler socket #'serve)) + ((nil) (serve-loop)))) + port)) + +(defun stop-server (port) + "Stop server running on PORT." + (send-to-sentinel `(:stop-server :port ,port))) + +(defun restart-server (&key (port default-server-port) + (style *communication-style*) + (dont-close *dont-close*)) + "Stop the server listening on PORT, then start a new SLYNK server +on PORT running in STYLE. If DONT-CLOSE is true then the listen socket +will accept multiple connections, otherwise it will be closed after the +first." + (stop-server port) + (sleep 5) + (create-server :port port :style style :dont-close dont-close)) + +(defun accept-connections (socket style dont-close) + (unwind-protect + (let ((client (accept-connection socket :external-format nil + :buffering t))) + (authenticate-client client) + (serve-requests (make-connection socket client style))) + (unless dont-close + (send-to-sentinel `(:stop-server :socket ,socket))))) + +(defun authenticate-client (stream) + (let ((secret (sly-secret))) + (when secret + (set-stream-timeout stream 20) + (let ((first-val (read-packet stream))) + (unless (and (stringp first-val) (string= first-val secret)) + (error "Incoming connection doesn't know the password."))) + (set-stream-timeout stream nil)))) + +(defun sly-secret () + "Finds the magic secret from the user's home directory. Returns nil +if the file doesn't exist; otherwise the first line of the file." + (with-open-file (in + (merge-pathnames (user-homedir-pathname) #p".sly-secret") + :if-does-not-exist nil) + (and in (read-line in nil "")))) + +(defun serve-requests (connection) + "Read and process all requests on connections." + (etypecase connection + (multithreaded-connection + (spawn-threads-for-connection connection)) + (singlethreaded-connection + (ecase (connection-communication-style connection) + ((nil) (simple-serve-requests connection)) + (:sigio (install-sigio-handler connection)) + (:fd-handler (install-fd-handler connection)))))) + +(defun stop-serving-requests (connection) + (etypecase connection + (multithreaded-connection + (cleanup-connection-threads connection)) + (singlethreaded-connection + (ecase (connection-communication-style connection) + ((nil)) + (:sigio (deinstall-sigio-handler connection)) + (:fd-handler (deinstall-fd-handler connection)))))) + +(defun announce-server-port (file port) + (with-open-file (s file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format s "~S~%" port)) + (simple-announce-function port)) + +(defun simple-announce-function (port) + (when *slynk-debug-p* + (format *log-output* "~&;; Slynk started at port: ~D.~%" port) + (force-output *log-output*))) + + +;;;;; Event Decoding/Encoding + +(defun decode-message (stream) + "Read an S-expression from STREAM using the SLY protocol." + (log-event "decode-message~%") + (without-sly-interrupts + (handler-bind ((error #'signal-slynk-error)) + (handler-case (read-message stream *slynk-io-package*) + (slynk-reader-error (c) + `(:reader-error ,(slynk-reader-error.packet c) + ,(slynk-reader-error.cause c))))))) + +(defun encode-message (message stream) + "Write an S-expression to STREAM using the SLY protocol." + (log-event "encode-message~%") + (without-sly-interrupts + (handler-bind ((error #'signal-slynk-error)) + (write-message message *slynk-io-package* stream)))) + + +;;;;; Event Processing + +(defvar *sly-db-quit-restart* nil + "The restart that will be invoked when the user calls sly-db-quit.") + +;; Establish a top-level restart and execute BODY. +;; Execute K if the restart is invoked. +(defmacro with-top-level-restart ((connection k) &body body) + `(with-connection (,connection) + (restart-case + (let ((*sly-db-quit-restart* (find-restart 'abort))) + ,@body) + (abort (&optional v) + :report "Return to SLY's top level." + (declare (ignore v)) + (force-user-output) + ,k)))) + +(defun handle-requests (connection &optional timeout) + "Read and process :emacs-rex requests. +The processing is done in the extent of the toplevel restart." + (with-connection (connection) + (cond (*sly-db-quit-restart* + (process-requests timeout)) + (t + (tagbody + start + (with-top-level-restart (connection (go start)) + (process-requests timeout))))))) + +(defvar-unbound *channel* + "Current CHANNEL instance used by :EMACS-CHANNEL-SEND messages.") + +(defun process-requests (timeout) + "Read and process requests from Emacs. +TIMEOUT has the same meaning as in WAIT-FOR-EVENT." + (catch 'stop-processing + (loop + (multiple-value-bind (event timed-out-p) + (wait-for-event `(or (:emacs-rex . _) + (:emacs-channel-send . _)) + timeout) + (when timed-out-p (return)) + (destructure-case event + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:emacs-channel-send *channel* (selector &rest args)) + (channel-send *channel* selector args))))))) + +(defun spawn-channel-thread (connection channel) + "Spawn a listener thread for CONNECTION and CHANNEL. + +The new thread will block waiting for a :SERVE-CHANNEL message, then +process all requests in series until the :TEARDOWN message, at which +point the thread terminates and CHANNEL is closed." + (slynk-backend:spawn + (lambda () + (with-connection (connection) + (unwind-protect + (destructure-case + (slynk-backend:receive) + ((:serve-channel c) + (assert (eq c channel)) + (loop + (with-top-level-restart (connection + (drop-unprocessed-events channel)) + (when (eq (process-requests nil) + 'listener-teardown) + (return)))))) + (close-channel channel)))) + :name (with-slots (id name) channel + (format nil "sly-channel-~a-~a" id name)))) + + +(defun current-socket-io () + (connection-socket-io *emacs-connection*)) + +(defun close-connection (connection condition backtrace) + (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace))) + +(defun close-connection% (c condition backtrace) + (let ((*debugger-hook* nil)) + (log-event "close-connection: ~a ...~%" condition) + (format *log-output* "~&;; slynk:close-connection: ~A~%" + (escape-non-ascii (safe-condition-message condition))) + (let ((*emacs-connection* c)) + (format *log-output* "~&;; closing ~a channels~%" (length (connection-channels c))) + (mapc #'(lambda (c) (close-channel c :force t)) (connection-channels c)) + (format *log-output* "~&;; closing ~a listeners~%" (length (connection-listeners c))) + (ignore-errors + (mapc #'close-listener (connection-listeners c)))) + (stop-serving-requests c) + (close (connection-socket-io c)) + (setf *connections* (remove c *connections*)) + (run-hook *connection-closed-hook* c) + (when (and condition (not (typep condition 'end-of-file))) + (finish-output *log-output*) + (format *log-output* "~&;; Event history start:~%") + (dump-event-history *log-output*) + (format *log-output* "~ +;; Event history end.~%~ +;; Backtrace:~%~{~A~%~}~ +;; Connection to Emacs lost. [~%~ +;; condition: ~A~%~ +;; type: ~S~%~ +;; style: ~S]~%" + (loop for (i f) in backtrace + collect + (ignore-errors + (format nil "~d: ~a" i (escape-non-ascii f)))) + (escape-non-ascii (safe-condition-message condition) ) + (type-of condition) + (connection-communication-style c))) + (finish-output *log-output*) + (log-event "close-connection ~a ... done.~%" condition))) + +;;;;;; Thread based communication + +(defun read-loop (connection) + (let ((input-stream (connection-socket-io connection)) + (control-thread (mconn.control-thread connection))) + (with-slynk-error-handler (connection) + (loop (send control-thread (decode-message input-stream)))))) + +(defun dispatch-loop (connection) + (let ((*emacs-connection* connection)) + (with-panic-handler (connection) + (loop (dispatch-event connection (receive)))))) + +(defgeneric thread-for-evaluation (connection id) + (:documentation "Find or create a thread to evaluate the next request.") + (:method ((connection multithreaded-connection) (id (eql t))) + (spawn-worker-thread connection)) + (:method ((connection multithreaded-connection) (id (eql :find-existing))) + (car (mconn.active-threads connection))) + (:method (connection (id integer)) + (declare (ignorable connection)) + (find-thread id)) + (:method ((connection singlethreaded-connection) id) + (declare (ignorable connection connection id)) + (current-thread))) + +(defun interrupt-worker-thread (connection id) + (let ((thread (thread-for-evaluation connection + (cond ((eq id t) :find-existing) + (t id))))) + (log-event "interrupt-worker-thread: ~a ~a~%" id thread) + (if thread + (etypecase connection + (multithreaded-connection + (queue-thread-interrupt thread #'simple-break)) + (singlethreaded-connection + (simple-break))) + (encode-message (list :debug-condition (current-thread-id) + (format nil "Thread with id ~a not found" + id)) + (current-socket-io))))) + +(defun spawn-worker-thread (connection) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (with-top-level-restart (connection nil) + (let ((thread (current-thread))) + (unwind-protect + (apply #'eval-for-emacs + (cdr (wait-for-event `(:emacs-rex . _)))) + (remove-active-thread connection thread)))))) + :name "slynk-worker")) + +(defun add-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (push thread (mconn.active-threads connection))) + (singlethreaded-connection))) + +(defun remove-active-thread (connection thread) + (etypecase connection + (multithreaded-connection + (setf (mconn.active-threads connection) + (delete thread (mconn.active-threads connection) :count 1))) + (singlethreaded-connection))) + +(defun dispatch-event (connection event) + "Handle an event triggered either by Emacs or within Lisp." + (log-event "dispatch-event: ~s~%" event) + (destructure-case event + ((:emacs-rex form package thread-id id &rest extra-rex-options) + (let ((thread (thread-for-evaluation connection thread-id))) + (cond (thread + (add-active-thread connection thread) + (send-event thread `(:emacs-rex ,form ,package ,id ,@extra-rex-options))) + (t + (encode-message + (list :invalid-rpc id + (format nil "Thread not found: ~s" thread-id)) + (current-socket-io)))))) + ((:return thread &rest args) + (declare (ignore thread)) + (encode-message `(:return ,@args) (current-socket-io))) + ((:emacs-interrupt thread-id) + (interrupt-worker-thread connection thread-id)) + (((:write-string + :debug :debug-condition :debug-activate :debug-return :channel-send + :presentation-start :presentation-end + :new-package :new-features :ed :indentation-update + :eval :eval-no-wait :background-message :inspect :ping + :y-or-n-p :read-from-minibuffer :read-string :read-aborted :test-delay) + &rest _) + (declare (ignore _)) + (encode-message event (current-socket-io))) + (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args) + (send-event (find-thread thread-id) (cons (car event) args))) + ((:emacs-channel-send channel-id msg) + (let* ((ch (find-channel channel-id)) + (thread (and ch (find-channel-thread ch)))) + (cond ((and ch thread) + (send-event thread `(:emacs-channel-send ,ch ,msg))) + (ch + (encode-message + (list :invalid-channel channel-id + "No suitable threads for channel") + (current-socket-io))) + (t + (encode-message + (list :invalid-channel channel-id "Channel not found") + (current-socket-io)))))) + ((:reader-error packet condition) + (encode-message `(:reader-error ,packet + ,(safe-condition-message condition)) + (current-socket-io))))) + + +(defun send-event (thread event) + (log-event "send-event: ~s ~s~%" thread event) + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send thread event)) + (singlethreaded-connection + (setf (sconn.event-queue c) (nconc (sconn.event-queue c) (list event))) + (setf (sconn.events-enqueued c) (mod (1+ (sconn.events-enqueued c)) + most-positive-fixnum)))))) + +(defun send-to-emacs (event) + "Send EVENT to Emacs." + ;;(log-event "send-to-emacs: ~a" event) + (without-sly-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (send (mconn.control-thread c) event)) + (singlethreaded-connection + (dispatch-event c event))) + (maybe-slow-down)))) + +(defun make-thread-bindings-aware-lambda (fn) + (let ((connection *emacs-connection*) + (send-counter *send-counter*)) + (lambda (&rest args) + (let ((*emacs-connection* connection) + (*send-counter* send-counter)) + (apply fn args))))) + + +;;;;;; Flow control + +;; After sending N (usually 100) messages we slow down and ping Emacs +;; to make sure that everything we have sent so far was received. + +(defconstant send-counter-limit 100) + +(defun maybe-slow-down () + (let ((counter (incf *send-counter*))) + (when (< send-counter-limit counter) + (setf *send-counter* 0) + (ping-pong)))) + +(defun ping-pong () + (let* ((tag (make-tag)) + (pattern `(:emacs-pong ,tag))) + (send-to-emacs `(:ping ,(current-thread-id) ,tag)) + (wait-for-event pattern))) + + +(defun wait-for-event (pattern &optional timeout) + "Scan the event queue for PATTERN and return the event. +If TIMEOUT is NIL wait until a matching event is enqued. +If TIMEOUT is T only scan the queue without waiting. +The second return value is t if the timeout expired before a matching +event was found." + (log-event "wait-for-event: ~s ~s~%" pattern timeout) + (without-sly-interrupts + (let ((c *emacs-connection*)) + (etypecase c + (multithreaded-connection + (receive-if (lambda (e) (event-match-p e pattern)) timeout)) + (singlethreaded-connection + (wait-for-event/event-loop c pattern timeout)))))) + +(defun wait-for-event/event-loop (connection pattern timeout) + (assert (or (not timeout) (eq timeout t))) + (loop + (check-sly-interrupts) + (let ((event (poll-for-event connection pattern))) + (when event (return (car event)))) + (let ((events-enqueued (sconn.events-enqueued connection)) + (ready (wait-for-input (list (current-socket-io)) timeout))) + (cond ((and timeout (not ready)) + (return (values nil t))) + ((or (/= events-enqueued (sconn.events-enqueued connection)) + (eq ready :interrupt)) + ;; rescan event queue, interrupts may enqueue new events + ) + (t + (assert (equal ready (list (current-socket-io)))) + (dispatch-event connection + (decode-message (current-socket-io)))))))) + +(defun poll-for-event (connection pattern) + (let* ((c connection) + (tail (member-if (lambda (e) (event-match-p e pattern)) + (sconn.event-queue c)))) + (when tail + (setf (sconn.event-queue c) + (nconc (ldiff (sconn.event-queue c) tail) (cdr tail))) + tail))) + +;;; FIXME: Make this use SLYNK-MATCH. +(defun event-match-p (event pattern) + (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern) + (member pattern '(nil t))) + (equal event pattern)) + ((symbolp pattern) t) + ((consp pattern) + (case (car pattern) + ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern))) + (t (and (consp event) + (and (event-match-p (car event) (car pattern)) + (event-match-p (cdr event) (cdr pattern))))))) + (t (error "Invalid pattern: ~S" pattern)))) + + + +(defun spawn-threads-for-connection (connection) + (setf + (mconn.control-thread connection) + (spawn + (lambda () + "Spawns a reader and indentation threads, then calls DISPATCH-LOOP." + (setf (mconn.reader-thread connection) (spawn (lambda () (read-loop connection)) + :name "reader-thread")) + (setf (mconn.indentation-cache-thread connection) + (spawn (lambda () (indentation-cache-loop connection)) + :name "slynk-indentation-cache-thread")) + (dispatch-loop connection)) + :name "control-thread")) + connection) + +(defun cleanup-connection-threads (connection) + (let* ((c connection) + (threads (list (mconn.reader-thread c) + (mconn.control-thread c) + (mconn.auto-flush-thread c) + (mconn.indentation-cache-thread c)))) + (dolist (thread threads) + (when (and thread + (thread-alive-p thread) + (not (equal (current-thread) thread))) + (ignore-errors (kill-thread thread)))))) + +;;;;;; Signal driven IO + +(defun install-sigio-handler (connection) + (add-sigio-handler (connection-socket-io connection) + (lambda () (process-io-interrupt connection))) + (handle-requests connection t)) + +(defvar *io-interupt-level* 0) + +(defun process-io-interrupt (connection) + (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*) + (let ((*io-interupt-level* (1+ *io-interupt-level*))) + (invoke-or-queue-interrupt + (lambda () (handle-requests connection t)))) + (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*)) + +(defun deinstall-sigio-handler (connection) + (log-event "deinstall-sigio-handler...~%") + (remove-sigio-handlers (connection-socket-io connection)) + (log-event "deinstall-sigio-handler...done~%")) + +;;;;;; SERVE-EVENT based IO + +(defun install-fd-handler (connection) + (add-fd-handler (connection-socket-io connection) + (lambda () (handle-requests connection t))) + (setf (sconn.saved-sigint-handler connection) + (install-sigint-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))))) + (handle-requests connection t)) + +(defun dispatch-interrupt-event (connection) + (with-connection (connection) + (dispatch-event connection `(:emacs-interrupt ,(current-thread-id))))) + +(defun deinstall-fd-handler (connection) + (log-event "deinstall-fd-handler~%") + (remove-fd-handlers (connection-socket-io connection)) + (install-sigint-handler (sconn.saved-sigint-handler connection))) + +;;;;;; Simple sequential IO + +(defun simple-serve-requests (connection) + (unwind-protect + (with-connection (connection) + (call-with-user-break-handler + (lambda () + (invoke-or-queue-interrupt + (lambda () (dispatch-interrupt-event connection)))) + (lambda () + (with-simple-restart (close-connection "Close SLY connection.") + (let* ((stdin (real-input-stream *standard-input*)) + (*standard-input* (make-repl-input-stream connection + stdin))) + (tagbody toplevel + (with-top-level-restart (connection (go toplevel)) + (simple-repl)))))))) + (close-connection connection nil (safe-backtrace)))) + +;; this is signalled when our custom stream thinks the end-of-file is reached. +;; (not when the end-of-file on the socket is reached) +(define-condition end-of-repl-input (end-of-file) ()) + +(defun simple-repl () + (loop + (format t "~a> " (package-string-for-prompt *package*)) + (force-output) + (let ((form (handler-case (read) + (end-of-repl-input () (return))))) + (let* ((- form) + (values (multiple-value-list (eval form)))) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + form) + (cond ((null values) (format t "; No values~&")) + (t (mapc (lambda (v) (format t "~s~&" v)) values))))))) + +(defun make-repl-input-stream (connection stdin) + (make-input-stream + (lambda () (repl-input-stream-read connection stdin)))) + +(defun repl-input-stream-read (connection stdin) + (loop + (let* ((socket (connection-socket-io connection)) + (inputs (list socket stdin)) + (ready (wait-for-input inputs))) + (cond ((eq ready :interrupt) + (check-sly-interrupts)) + ((member socket ready) + ;; A Sly request from Emacs is pending; make sure to + ;; redirect IO to the REPL buffer. + (with-simple-restart (process-input "Continue reading input.") + (let ((*sly-db-quit-restart* (find-restart 'process-input))) + (with-default-listener (connection) + (handle-requests connection t))))) + ((member stdin ready) + ;; User typed something into the *inferior-lisp* buffer, + ;; so do not redirect. + (return (read-non-blocking stdin))) + (t (assert (null ready))))))) + +(defun read-non-blocking (stream) + (with-output-to-string (str) + (handler-case + (loop (let ((c (read-char-no-hang stream))) + (unless c (return)) + (write-char c str))) + (end-of-file () (error 'end-of-repl-input :stream stream))))) + + + +(defvar *sly-features* nil + "The feature list that has been sent to Emacs.") + +(defun send-oob-to-emacs (object) + (send-to-emacs object)) + +(defun force-user-output () + (with-default-listener (*emacs-connection*) + (force-output *standard-output*))) + +(add-hook *pre-reply-hook* 'force-user-output) + +(defun clear-user-input () + (with-default-listener (*emacs-connection*) + (clear-input *standard-input*))) + +;; FIXME: not thread safe. +(defvar *tag-counter* 0) + +(defun make-tag () + (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22)))) + +(defun y-or-n-p-in-emacs (format-string &rest arguments) + "Like y-or-n-p, but ask in the Emacs minibuffer." + (let ((tag (make-tag)) + (question (apply #'format nil format-string arguments))) + (force-output) + (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defun read-from-minibuffer-in-emacs (prompt &optional initial-value) + "Ask user a question in Emacs' minibuffer. Returns \"\" when user +entered nothing, returns NIL when user pressed C-g." + (check-type prompt string) (check-type initial-value (or null string)) + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag + ,prompt ,initial-value)) + (third (wait-for-event `(:emacs-return ,tag result))))) + +(defun process-form-for-emacs (form) + "Returns a string which emacs will read as equivalent to +FORM. FORM can contain lists, strings, characters, symbols and +numbers. + +Characters are converted emacs' ? notaion, strings are left +as they are (except for espacing any nested \" chars, numbers are +printed in base 10 and symbols are printed as their symbol-name +converted to lower case." + (etypecase form + (string (format nil "~S" form)) + (cons (format nil "(~A . ~A)" + (process-form-for-emacs (car form)) + (process-form-for-emacs (cdr form)))) + (character (format nil "?~C" form)) + (symbol (concatenate 'string (when (eq (symbol-package form) + #.(find-package "KEYWORD")) + ":") + (string-downcase (symbol-name form)))) + (number (let ((*print-base* 10)) + (princ-to-string form))))) + +(defun eval-in-emacs (form &optional nowait) + "Eval FORM in Emacs. +`sly-enable-evaluate-in-emacs' should be set to T on the Emacs side." + (cond (nowait + (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form)))) + (t + (force-output) + (let ((tag (make-tag))) + (send-to-emacs `(:eval ,(current-thread-id) ,tag + ,(process-form-for-emacs form))) + (let ((value (caddr (wait-for-event `(:emacs-return ,tag result))))) + (destructure-case value + ((:ok value) value) + ((:error kind . data) (error "~a: ~{~a~}" kind data)) + ((:abort) (abort)))))))) + +(defun sly-version-string () + "Return a string identifying the SLY version. +Return nil if nothing appropriate is available." + (let ((this-file #.(or *compile-file-truename* *load-truename*))) + (with-open-file (s (make-pathname :name "sly" :type "el" + :directory (butlast + (pathname-directory this-file) + 1) + :defaults this-file)) + (let ((seq (make-array 200 :element-type 'character :initial-element #\null))) + (read-sequence seq s :end 200) + (let* ((beg (search ";; Version:" seq)) + (end (position #\NewLine seq :start beg)) + (middle (position #\Space seq :from-end t :end end))) + (subseq seq (1+ middle) end)))))) + +(defvar *slynk-wire-protocol-version* (ignore-errors (sly-version-string)) + "The version of the slynk/sly communication protocol.") + +(defslyfun connection-info () + "Return a key-value list of the form: +\(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION) +PID: is the process-id of Lisp process (or nil, depending on the STYLE) +STYLE: the communication style +LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION PROGRAM) +FEATURES: a list of keywords +PACKAGE: a list (&key NAME PROMPT) +VERSION: the protocol version" + (let ((c *emacs-connection*)) + (setq *sly-features* *features*) + `(:pid ,(getpid) :style ,(connection-communication-style c) + :encoding (:coding-systems + ,(loop for cs in '("utf-8-unix" "iso-latin-1-unix") + when (find-external-format cs) collect cs)) + :lisp-implementation (:type ,(lisp-implementation-type) + :name ,(lisp-implementation-type-name) + :version ,(lisp-implementation-version) + :program ,(lisp-implementation-program)) + :machine (:instance ,(machine-instance) + :type ,(machine-type) + :version ,(machine-version)) + :features ,(features-for-emacs) + :modules ,*modules* + :package (:name ,(package-name *package*) + :prompt ,(package-string-for-prompt *package*)) + :version ,*slynk-wire-protocol-version*))) + +(defun debug-on-slynk-error () + (assert (eq *debug-on-slynk-protocol-error* *debug-slynk-backend*)) + *debug-on-slynk-protocol-error*) + +(defun (setf debug-on-slynk-error) (new-value) + (setf *debug-on-slynk-protocol-error* new-value) + (setf *debug-slynk-backend* new-value)) + +(defslyfun toggle-debug-on-slynk-error () + (setf (debug-on-slynk-error) (not (debug-on-slynk-error)))) + + +;;;; Reading and printing + +(defvar-unbound *buffer-package* + "Package corresponding to sly-buffer-package. + +EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a sly +buffer are best read in this package. See also FROM-STRING and TO-STRING.") + +(defvar-unbound *buffer-readtable* + "Readtable associated with the current buffer") + +(defmacro with-buffer-syntax ((&optional package-designator + readtable) + &body body) + "Conceptually execute BODY inside a SLY Lisp buffer. + +Execute BODY with appropriate *PACKAGE* and *READTABLE* bindings. + +PACKAGE-DESIGNATOR, if non-NIL, is anything remotely designating a +package. READTABLE, if non-NIL, must verify CL:READTABLEP. + +READTABLE defaults to *BUFFER-READTABLE* as set by +GUESS-BUFFER-READTABLE, which in turn uses a mapping in +*READTABLE-ALIST* as indexed by *BUFFER-PACKAGE*, and *not* +PACKAGE-DESIGNATOR. + +This should be used for code that is conceptionally executed in an +Emacs buffer." + `(call-with-buffer-syntax ,package-designator ,readtable (lambda () ,@body))) + +(defun call-with-buffer-syntax (package readtable fun) + (let ((*package* (if package + (guess-buffer-package package) + *buffer-package*)) + (*buffer-readtable* (or (and (readtablep readtable) + readtable) + *buffer-readtable*))) + ;; Don't shadow *readtable* unnecessarily because that prevents + ;; the user from assigning to it. + (if (eq *readtable* *buffer-readtable*) + (call-with-syntax-hooks fun) + (let ((*readtable* *buffer-readtable*)) + (call-with-syntax-hooks fun))))) + +(defmacro without-printing-errors ((&key object stream + (msg "<>")) + &body body) + ;; JT: Careful when calling this, make sure STREAM, if provided, is + ;; a symbol that alwyas designates a non-nil stream. See gh#287. + "Catches errors during evaluation of BODY and prints MSG instead." + `(handler-case (progn ,@body) + (serious-condition () + ,(cond ((and stream object) + (let ((gstream (gensym "STREAM+"))) + `(let ((,gstream ,stream)) + (print-unreadable-object (,object ,gstream :type t + :identity t) + (write-string ,msg ,gstream))))) + (stream + `(write-string ,msg ,stream)) + (object + `(with-output-to-string (s) + (print-unreadable-object (,object s :type t :identity t) + (write-string ,msg s)))) + (t msg))))) + +(defun to-string (object) + "Write OBJECT in the *BUFFER-PACKAGE*. +The result may not be readable. Handles problems with PRINT-OBJECT methods +gracefully." + (with-buffer-syntax () + (let ((*print-readably* nil)) + (without-printing-errors (:object object :stream nil) + (prin1-to-string object))))) + +(defun from-string (string) + "Read string in the *BUFFER-PACKAGE*" + (with-buffer-syntax () + (let ((*read-suppress* nil)) + (values (read-from-string string))))) + +(defun parse-string (string package) + "Read STRING in PACKAGE." + (with-buffer-syntax (package) + (let ((*read-suppress* nil)) + (read-from-string string)))) + +;; FIXME: deal with #\| etc. hard to do portably. +(defun tokenize-symbol (string) + "STRING is interpreted as the string representation of a symbol +and is tokenized accordingly. The result is returned in three +values: The package identifier part, the actual symbol identifier +part, and a flag if the STRING represents a symbol that is +internal to the package identifier part. (Notice that the flag is +also true with an empty package identifier part, as the STRING is +considered to represent a symbol internal to some current package.)" + (let ((package (let ((pos (position #\: string))) + (if pos (subseq string 0 pos) nil))) + (symbol (let ((pos (position #\: string :from-end t))) + (if pos (subseq string (1+ pos)) string))) + (internp (not (= (count #\: string) 1)))) + (values symbol package internp))) + +(defun tokenize-symbol-thoroughly (string) + "This version of TOKENIZE-SYMBOL handles escape characters." + (let ((package nil) + (token (make-array (length string) :element-type 'character + :fill-pointer 0)) + (backslash nil) + (vertical nil) + (internp nil) + (caser (char-casifier string))) + (loop for char across string do + (cond + (backslash + (vector-push-extend char token) + (setq backslash nil)) + ((char= char #\\) ; Quotes next character, even within |...| + (setq backslash t)) + ((char= char #\|) + (setq vertical (not vertical))) + (vertical + (vector-push-extend char token)) + ((char= char #\:) + (cond ((and package internp) + (return-from tokenize-symbol-thoroughly)) + (package + (setq internp t)) + (t + (setq package token + token (make-array (length string) + :element-type 'character + :fill-pointer 0))))) + (t + (vector-push-extend (funcall caser char) token)))) + (unless vertical + (values token package (or (not package) internp))))) + +(defun untokenize-symbol (package-name internal-p symbol-name) + "The inverse of TOKENIZE-SYMBOL. + + (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\" + (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\" + (untokenize-symbol nil nil \"foo\") ==> \"foo\" +" + (cond ((not package-name) symbol-name) + (internal-p (cat package-name "::" symbol-name)) + (t (cat package-name ":" symbol-name)))) + +(defun char-casifier (string) + "Return a function which converts characters in STRING according to `readtable-case'." + (ecase (readtable-case *readtable*) + (:preserve #'identity) + (:upcase #'char-upcase) + (:downcase #'char-downcase) + ;; :invert only inverts the case if every character of a token is the same + ;; case, otherwise it acts like :preserve. + (:invert (let ((upper (count-if #'upper-case-p string))) + (cond ((= upper 0) #'char-upcase) + ((= upper (length string)) #'char-downcase) + (t #'identity)))))) + + +(defun find-symbol-with-status (symbol-name status + &optional (package *package*)) + (multiple-value-bind (symbol flag) (find-symbol symbol-name package) + (if (and flag (eq flag status)) + (values symbol flag) + (values nil nil)))) + +(defun parse-symbol (string &optional (package *package*)) + "Find the symbol named STRING. +Return the symbol and a flag indicating whether the symbols was found." + (multiple-value-bind (sname pname internalp) + (tokenize-symbol-thoroughly string) + (when sname + (let ((package (cond ((string= pname "") +keyword-package+) + (pname (find-package pname)) + (t package)))) + (if package + (multiple-value-bind (symbol flag) + (if internalp + (find-symbol sname package) + (find-symbol-with-status sname ':external package)) + (values symbol flag sname package)) + (values nil nil nil nil)))))) + +(defun parse-symbol-or-lose (string &optional (package *package*)) + (multiple-value-bind (symbol status) (parse-symbol string package) + (if status + (values symbol status) + (error "Unknown symbol: ~A [in ~A]" string package)))) + +(defun parse-package (string) + "Find the package named STRING. +Return the package or nil." + ;; STRING comes usually from a (in-package STRING) form. + (ignore-errors + (find-package (let ((*package* *slynk-io-package*)) + (read-from-string string))))) + +(defun unparse-name (string) + "Print the name STRING according to the current printer settings." + ;; this is intended for package or symbol names + (subseq (prin1-to-string (make-symbol string)) 2)) + +(defun guess-package (string) + "Guess which package corresponds to STRING. +Return nil if no package matches." + (when string + (or (find-package string) + (parse-package string) + (if (find #\! string) ; for SBCL + (guess-package (substitute #\- #\! string)))))) + +(defvar *readtable-alist* (default-readtable-alist) + "An alist mapping package names to readtables.") + +(defun guess-buffer-readtable (package-name) + (let ((package (guess-package package-name))) + (or (and package + (cdr (assoc (package-name package) *readtable-alist* + :test #'string=))) + *readtable*))) + + +;;;; Evaluation + +(defvar *pending-continuations* '() + "List of continuations for Emacs. (thread local)") + +(defun guess-buffer-package (string) + "Return a package for STRING. +Fall back to the current if no such package exists." + (or (and string (guess-package string)) + *package*)) + +(defvar *eval-for-emacs-wrappers* nil + "List of functions for fine-grained control over form evaluation. +Each element must be a function taking an arbitrary number of +arguments, the first of which is a function of no arguments, call it +IN-FUNCTION, while the remaining are bound to the EXTRA-REX-OPTIONS +parameter of EVAL-FOR-EMACS. Every function *must* return another +function of no arguments, call it OUT-FUNCTION, that, when called, +*must* call IN-FUNCTION in whatever dynamic environment it sees fit. + +Slynk will go through the elements of this variable in order, passing +a function that evaluates the form coming from Emacs to the first +element until it collects the result of the last, which is finally +called with no arguments. + +Be careful when changing this variable since you may mess very basic +functionality of your Slynk, including the ability to correct any +errors you make.") + +(defun eval-for-emacs (form buffer-package id &rest extra-rex-options) + "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM. +Return the result to the continuation ID. Errors are trapped and +invoke our debugger. EXTRA-REX-OPTIONS are passed to the functions of +*EVAL-FOR-EMACS-WRAPPERS*, which see." + (let (ok result condition) + (unwind-protect + (let ((*buffer-package* (guess-buffer-package buffer-package)) + (*buffer-readtable* (guess-buffer-readtable buffer-package)) + (*pending-continuations* (cons id *pending-continuations*))) + (check-type *buffer-package* package) + (check-type *buffer-readtable* readtable) + (handler-bind ((t (lambda (c) (setf condition c)))) + (setq result (with-sly-interrupts + (flet ((eval-it () + ;; APPLY would be cleaner than EVAL. + ;; (setq result (apply (car form) (cdr form))) + (eval form))) + ;; Honour *EVAL-FOR-EMACS-WRAPPERS* + ;; + (loop for lambda = #'eval-it then + (handler-case + (apply wrapper lambda extra-rex-options) + (error (e) + (warn "~s ignoring wrapper ~a (~a)" + 'eval-for-emacs wrapper e) + lambda)) + for wrapper in *eval-for-emacs-wrappers* + finally (return (funcall lambda))))))) + (run-hook *pre-reply-hook*) + (setq ok t)) + (send-to-emacs `(:return ,(current-thread) + ,(if ok + `(:ok ,result) + `(:abort ,(prin1-to-string condition))) + ,id))))) + +(defun format-integer-length (i) (format nil "~a bit~:p" (integer-length i))) +(defun format-integer-as-hex (i) + (unless (or (minusp i) (> (integer-length i) 64)) (format nil "#x~X" i))) +(defun format-integer-as-octal (i) + (unless (or (minusp i) (> (integer-length i) 8)) (format nil "#o~O" i))) +(defun format-integer-as-binary (i) -128 + (unless (or (minusp i) (> (integer-length i) 8)) (format nil "#b~B" i))) +(defun format-ratio-as-float (r) (ignore-errors (format nil "~f" r))) +(defun format-as-percentage-maybe (f) (when (< 0 (abs f) 2) (format nil "~2,'0d%" (* f 100)))) + +(defparameter *echo-number-alist* + '((integer . (format-integer-length format-integer-as-hex format-integer-as-octal format-integer-as-binary)) + (ratio . (format-ratio-as-float format-as-percentage-maybe)) + (float . (format-as-percentage-maybe))) + "Alist of functions used for presenting numbers in the echo area. + +Each element takes the form (TYPE . FUNCTIONS), where TYPE is a type +designator and FUNCTIONS is a list of function designators for +displaying that number in SLY. Each function takes the number as a +single argument and returns a string, or nil, if that particular +representation is to be disregarded. + +Additionally if a given function chooses to return t as its optional +second value, then all the remaining functions following it in the +list are disregarded.") + +(defparameter *present-number-alist* nil + "Alist of functions used for presenting numbers the REPL. + +This is an \"override\". If nil the (the alist is empty) the value of +*ECHO-NUMBER-ALIST* is used, otherwise the structure is exactly the +same as that variable.") + +(defun present-number-considering-alist (number alist) + (let* ((functions (cdr (assoc number alist :test #'typep))) + (extra-presentations + (loop for fn in functions + for (display skip) + = (multiple-value-list + (handler-case + (funcall fn number) + (error (e) + (declare (ignore e)) + ""))) + when display collect it + until skip))) + (if extra-presentations + (format nil "~A (~{~a~^, ~})" + number extra-presentations) + (format nil "~A" number)))) + +(defun echo-for-emacs (values &optional (fn #'slynk-pprint)) + "Format VALUES in a way suitable to be echoed in the SLY client. +May insert newlines between each of VALUES. Considers +*ECHO-NUMBER-ALIST*." + (let ((*print-readably* nil)) + (cond ((null values) "; No value") + ((and (numberp (car values)) + (null (cdr values))) + (present-number-considering-alist (car values) *echo-number-alist*)) + (t + (let ((strings (loop for v in values + collect (funcall fn v)))) + (if (some #'(lambda (s) (find #\Newline s)) + strings) + (format nil "~{~a~^~%~}" strings) + (format nil "~{~a~^, ~}" strings))))))) + +(defun present-for-emacs (value &optional (fn #'slynk-pprint)) + "Format VALUE in a way suitable to be displayed in the SLY client. +FN is only used if value is not a number" + (if (numberp value) + (present-number-considering-alist value (or *present-number-alist* + *echo-number-alist*)) + (funcall fn value))) + +(defslyfun interactive-eval (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY interactive evaluation request.") + (let ((values (multiple-value-list (eval (from-string string))))) + (finish-output) + (echo-for-emacs values))))) + +(defslyfun eval-and-grab-output (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY evaluation request.") + (let* ((s (make-string-output-stream)) + (*standard-output* s) + (values (multiple-value-list (eval (from-string string))))) + (list (get-output-stream-string s) + (echo-for-emacs values)))))) + +(defun eval-region (string) + "Evaluate STRING. +Return the results of the last form as a list and as secondary value the +last form." + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (finish-output) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (eval form))) + (finish-output)))))) + +(defslyfun interactive-eval-region (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY interactive evaluation request.") + (echo-for-emacs (eval-region string))))) + +(defslyfun re-evaluate-defvar (form) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY evaluation request.") + (let ((form (read-from-string form))) + (destructuring-bind (dv name &optional value doc) form + (declare (ignore value doc)) + (assert (eq dv 'defvar)) + (makunbound name) + (prin1-to-string (eval form))))))) + +(defvar-unbound *string-elision-length* + "Maximum length of a sring before elision by SLYNK-PPRINT.") + +(defparameter *slynk-pprint-bindings* + `((*print-pretty* . t) + (*print-level* . nil) + (*print-length* . nil) + (*string-elision-length* . 200) + (*print-circle* . nil) + (*print-gensym* . t) + (*print-readably* . nil)) + "A list of variables bindings during pretty printing. +Used by pprint-eval.") + +(defun slynk-pprint (object &key (stream nil)) + "Pretty print OBJECT to STREAM using *SLYNK-PPRINT-BINDINGS*. +If STREAM is nil, use a string" + (with-bindings *slynk-pprint-bindings* + ;; a failsafe for *PRINT-LENGTH* and *PRINT-LEVEL*: if they're NIL + ;; and *PRINT-CIRCLE* is also nil we could be in trouble printing + ;; recursive structures. + ;; + (let ((*print-length* (or *print-length* + (and (not *print-circle*) 512))) + (*print-level* (or *print-level* + (and (not *print-circle*) 20)))) + (flet ((write-it (s) + (cond ((and *string-elision-length* + (stringp object) + (> (length object) *string-elision-length*)) + (format s "\"~a...[sly-elided string of length ~a]\"" + (subseq object 0 *string-elision-length*) + (length object))) + (t + (write object :stream s :pretty t :escape t))))) + (if stream + (without-printing-errors (:object object :stream stream) + (write-it stream)) + (without-printing-errors (:object object) + (with-output-to-string (s) (write-it s)))))))) + +(defun slynk-pprint-values (values &key (stream nil)) + "Pretty print each of VALUES to STREAM using *SLYNK-PPRINT-BINDINGS*. +Separated by a newline. If no values indicate that in a comment. +If STREAM is nil, use a string" + (labels ((print-one (object s) + (let ((*slynk-pprint-bindings* nil)) + (slynk-pprint object :stream s))) + (print-all (s) + (loop for o in values + do (print-one o s) + (terpri)))) + (with-bindings *slynk-pprint-bindings* + (cond ((null values) + (format stream "; No value")) + (t + (if stream + (print-all stream) + (with-output-to-string (s) + (print-all s)))))))) + +(defun slynk-pprint-to-line (object) + "Print OBJECT to a single line string and return it." + (let ((*slynk-pprint-bindings* + `((*print-lines* . 1) + (*print-right-margin* . 512) + ,@*slynk-pprint-bindings*))) + (substitute #\Space #\Newline (slynk-pprint object :stream nil)))) + +(defslyfun pprint-eval (string) + (with-buffer-syntax () + (let* ((s (make-string-output-stream)) + (values + (let ((*standard-output* s) + (*trace-output* s)) + (multiple-value-list (eval (read-from-string string)))))) + (cat (get-output-stream-string s) + (slynk-pprint-values values))))) + +(defslyfun set-package (name) + "Set *package* to the package named NAME. +Return the full package-name and the string to use in the prompt." + (let ((p (guess-package name))) + (assert (packagep p) nil "Package ~a doesn't exist." name) + (setq *package* p) + (list (package-name p) (package-string-for-prompt p)))) + +(defun cat (&rest strings) + "Concatenate all arguments and make the result a string." + (with-output-to-string (out) + (dolist (s strings) + (etypecase s + (string (write-string s out)) + (character (write-char s out)))))) + +(defun truncate-string (string width &optional ellipsis) + (let ((len (length string))) + (cond ((< len width) string) + (ellipsis (cat (subseq string 0 width) ellipsis)) + (t (subseq string 0 width))))) + +(defun call/truncated-output-to-string (length function + &optional (ellipsis "..")) + "Call FUNCTION with a new stream, return the output written to the stream. +If FUNCTION tries to write more than LENGTH characters, it will be +aborted and return immediately with the output written so far." + (let ((buffer (make-string (+ length (length ellipsis)))) + (fill-pointer 0)) + (block buffer-full + (flet ((write-output (string) + (let* ((free (- length fill-pointer)) + (count (min free (length string)))) + (replace buffer string :start1 fill-pointer :end2 count) + (incf fill-pointer count) + (when (> (length string) free) + (replace buffer ellipsis :start1 fill-pointer) + (return-from buffer-full buffer))))) + (let ((stream (make-output-stream #'write-output))) + (funcall function stream) + (finish-output stream) + (subseq buffer 0 fill-pointer)))))) + +(defmacro with-string-stream ((var &key length bindings) + &body body) + (cond ((and (not bindings) (not length)) + `(with-output-to-string (,var) . ,body)) + ((not bindings) + `(call/truncated-output-to-string + ,length (lambda (,var) . ,body))) + (t + `(with-bindings ,bindings + (with-string-stream (,var :length ,length) + . ,body))))) + +(defun escape-string (string stream &key length (map '((#\" . "\\\"") + (#\\ . "\\\\")))) + "Write STRING to STREAM surronded by double-quotes. +LENGTH -- if non-nil truncate output after LENGTH chars. +MAP -- rewrite the chars in STRING according to this alist." + (let ((limit (or length array-dimension-limit))) + (write-char #\" stream) + (loop for c across string + for i from 0 do + (when (= i limit) + (write-string "..." stream) + (return)) + (let ((probe (assoc c map))) + (cond (probe (write-string (cdr probe) stream)) + (t (write-char c stream))))) + (write-char #\" stream))) + + +;;;; Prompt + +;; FIXME: do we really need 45 lines of code just to figure out the +;; prompt? + +(defvar *canonical-package-nicknames* + `((:common-lisp-user . :cl-user)) + "Canonical package names to use instead of shortest name/nickname.") + +(defvar *auto-abbreviate-dotted-packages* t + "Abbreviate dotted package names to their last component if T.") + +(defun package-string-for-prompt (package) + "Return the shortest nickname (or canonical name) of PACKAGE." + (unparse-name + (or (canonical-package-nickname package) + (auto-abbreviated-package-name package) + (shortest-package-nickname package)))) + +(defun canonical-package-nickname (package) + "Return the canonical package nickname, if any, of PACKAGE." + (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames* + :test #'string=)))) + (and name (string name)))) + +(defun auto-abbreviated-package-name (package) + "Return an abbreviated 'name' for PACKAGE. + +N.B. this is not an actual package name or nickname." + (when *auto-abbreviate-dotted-packages* + (loop with package-name = (package-name package) + with offset = nil + do (let ((last-dot-pos (position #\. package-name :end offset + :from-end t))) + (unless last-dot-pos + (return nil)) + ;; If a dot chunk contains only numbers, that chunk most + ;; likely represents a version number; so we collect the + ;; next chunks, too, until we find one with meat. + (let ((name (subseq package-name (1+ last-dot-pos) offset))) + (if (notevery #'digit-char-p name) + (return (subseq package-name (1+ last-dot-pos))) + (setq offset last-dot-pos))))))) + +(defun shortest-package-nickname (package) + "Return the shortest nickname of PACKAGE." + (loop for name in (cons (package-name package) (package-nicknames package)) + for shortest = name then (if (< (length name) (length shortest)) + name + shortest) + finally (return shortest))) + + + +(defslyfun ed-in-emacs (&optional what) + "Edit WHAT in Emacs. + +WHAT can be: + A pathname or a string, + A list (PATHNAME-OR-STRING &key LINE COLUMN POSITION), + A function name (symbol or cons), + NIL. " + (flet ((canonicalize-filename (filename) + (pathname-to-filename (or (probe-file filename) filename)))) + (let ((target + (etypecase what + (null nil) + ((or string pathname) + `(:filename ,(canonicalize-filename what))) + ((cons (or string pathname) *) + `(:filename ,(canonicalize-filename (car what)) ,@(cdr what))) + ((or symbol cons) + `(:function-name ,(prin1-to-string what)))))) + (cond (*emacs-connection* (send-oob-to-emacs `(:ed ,target))) + ((default-connection) + (with-connection ((default-connection)) + (send-oob-to-emacs `(:ed ,target)))) + (t (error "No connection")))))) + +(defslyfun inspect-in-emacs (what &key wait) + "Inspect WHAT in Emacs. If WAIT is true (default NIL) blocks until the +inspector has been closed in Emacs." + (flet ((send-it () + (let ((tag (when wait (make-tag))) + (thread (when wait (current-thread-id)))) + (with-buffer-syntax () + (reset-inspector) + (send-oob-to-emacs `(:inspect ,(inspect-object what) + ,thread + ,tag))) + (when wait + (wait-for-event `(:emacs-return ,tag result)))))) + (cond + (*emacs-connection* + (send-it)) + ((default-connection) + (with-connection ((default-connection)) + (send-it)))) + what)) + +(defslyfun value-for-editing (form) + "Return a readable value of FORM for editing in Emacs. +FORM is expected, but not required, to be SETF'able." + ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005) + (with-buffer-syntax () + (let* ((value (eval (read-from-string form))) + (*print-length* nil)) + (prin1-to-string value)))) + +(defslyfun commit-edited-value (form value) + "Set the value of a setf'able FORM to VALUE. +FORM and VALUE are both strings from Emacs." + (with-buffer-syntax () + (eval `(setf ,(read-from-string form) + ,(read-from-string (concatenate 'string "`" value)))) + t)) + +(defun background-message (format-string &rest args) + "Display a message in Emacs' echo area. + +Use this function for informative messages only. The message may even +be dropped if we are too busy with other things." + (when *emacs-connection* + (send-to-emacs `(:background-message + ,(apply #'format nil format-string args))))) + +;; This is only used by the test suite. +(defun sleep-for (seconds) + "Sleep for at least SECONDS seconds. +This is just like cl:sleep but guarantees to sleep +at least SECONDS." + (let* ((start (get-internal-real-time)) + (end (+ start + (* seconds internal-time-units-per-second)))) + (loop + (let ((now (get-internal-real-time))) + (cond ((< end now) (return)) + (t (sleep (/ (- end now) + internal-time-units-per-second)))))))) + + +;;;; Debugger + +(defun invoke-sly-debugger (condition) + "Sends a message to Emacs declaring that the debugger has been entered, +then waits to handle further requests from Emacs. Eventually returns +after Emacs causes a restart to be invoked." + (without-sly-interrupts + (cond (*emacs-connection* + (debug-in-emacs condition)) + ((default-connection) + (with-connection ((default-connection)) + (debug-in-emacs condition)))))) + +(define-condition invoke-default-debugger () ()) + +(defun slynk-debugger-hook (condition hook) + "Debugger function for binding *DEBUGGER-HOOK*." + (declare (ignore hook)) + (handler-case + (call-with-debugger-hook #'slynk-debugger-hook + (lambda () (invoke-sly-debugger condition))) + (invoke-default-debugger () + (invoke-default-debugger condition)))) + +(defun invoke-default-debugger (condition) + (call-with-debugger-hook nil (lambda () (invoke-debugger condition)))) + +(defvar *global-debugger* t + "Non-nil means the Slynk debugger hook will be installed globally.") + +(add-hook *new-connection-hook* 'install-debugger) +(defun install-debugger (connection) + (declare (ignore connection)) + (when *global-debugger* + (install-debugger-globally #'slynk-debugger-hook))) + +;;;;; Debugger loop +;;; +;;; These variables are dynamically bound during debugging. +;;; +(defvar *slynk-debugger-condition* nil + "The condition being debugged.") + +(defvar *sly-db-level* 0 + "The current level of recursive debugging.") + +(defvar *sly-db-initial-frames* 20 + "The initial number of backtrace frames to send to Emacs.") + +(defvar *sly-db-restarts* nil + "The list of currenlty active restarts.") + +(defvar *sly-db-stepping-p* nil + "True during execution of a step command.") + +(defun debug-in-emacs (condition) + (let ((*slynk-debugger-condition* condition) + (*sly-db-restarts* (compute-restarts condition)) + (*sly-db-quit-restart* (and *sly-db-quit-restart* + (find-restart *sly-db-quit-restart* + condition))) + (*package* (or (and (boundp '*buffer-package*) + (symbol-value '*buffer-package*)) + *package*)) + (*sly-db-level* (1+ *sly-db-level*)) + (*sly-db-stepping-p* nil)) + (force-user-output) + (call-with-debugging-environment + (lambda () + (sly-db-loop *sly-db-level*))))) + +(defun sly-db-loop (level) + (unwind-protect + (loop + (with-simple-restart (abort "Return to sly-db level ~D." level) + (send-to-emacs + (list* :debug (current-thread-id) level + (debugger-info-for-emacs 0 *sly-db-initial-frames*))) + (send-to-emacs + (list :debug-activate (current-thread-id) level)) + (loop + (handler-case + (destructure-case (wait-for-event + `(or (:emacs-rex . _) + (:emacs-channel-send . _) + (:sly-db-return ,(1+ level)))) + ((:emacs-rex &rest args) (apply #'eval-for-emacs args)) + ((:emacs-channel-send channel (selector &rest args)) + (channel-send channel selector args)) + ((:sly-db-return _) (declare (ignore _)) (return nil))) + (sly-db-condition (c) + (handle-sly-db-condition c)))))) + (send-to-emacs `(:debug-return + ,(current-thread-id) ,level ,*sly-db-stepping-p*)) + (wait-for-event `(:sly-db-return ,(1+ level)) t) ; clean event-queue + (when (> level 1) + (send-event (current-thread) `(:sly-db-return ,level))))) + +(defun handle-sly-db-condition (condition) + "Handle an internal debugger condition. +Rather than recursively debug the debugger (a dangerous idea!), these +conditions are simply reported." + (let ((real-condition (original-condition condition))) + (send-to-emacs `(:debug-condition ,(current-thread-id) + ,(princ-to-string real-condition))))) + +(defun %%condition-message (condition) + (let ((limit (ash 1 16))) + (with-string-stream (stream :length limit) + (handler-case + (let ((*print-readably* nil) + (*print-pretty* t) + (*print-right-margin* 65) + (*print-circle* t) + (*print-length* (or *print-length* limit)) + (*print-level* (or *print-level* limit)) + (*print-lines* (or *print-lines* limit))) + (print-condition condition stream)) + (serious-condition (c) + (ignore-errors + (with-standard-io-syntax + (let ((*print-readably* nil)) + (format stream "~&Error (~a) printing the following condition: " (type-of c)) + (print-unreadable-object (condition stream :type t + :identity t)))))))))) + +(defun %condition-message (condition) + (string-trim #(#\newline #\space #\tab) + (%%condition-message condition))) + +(defvar *sly-db-condition-printer* #'%condition-message + "Function called to print a condition to an SLY-DB buffer.") + +(defun safe-condition-message (condition) + "Print condition to a string, handling any errors during printing." + (funcall *sly-db-condition-printer* condition)) + +(defvar *debugger-extra-options* nil + ;; JT@15/08/24: FIXME: Actually, with a nice and proper method-combination for + ;; interfaces (as was once quite bravely attempted by Helmut, this variable + ;; could go away and contribs could simply add methods to CONDITION-EXTRAS) + ;; + "A property list of extra options describing a condition. +This works much like the CONDITION-EXTRAS interface, but can be +dynamically bound by contribs when invoking the debugger.") + +(defun debugger-condition-for-emacs () + (list (safe-condition-message *slynk-debugger-condition*) + (format nil " [Condition of type ~S]" + (type-of *slynk-debugger-condition*)) + (append (condition-extras *slynk-debugger-condition*) + *debugger-extra-options*))) + +(defun format-restarts-for-emacs () + "Return a list of restarts for *slynk-debugger-condition* in a +format suitable for Emacs." + (let ((*print-right-margin* most-positive-fixnum)) + (loop for restart in *sly-db-restarts* collect + (list (format nil "~:[~;*~]~a" + (eq restart *sly-db-quit-restart*) + (restart-name restart)) + (with-output-to-string (stream) + (without-printing-errors (:object restart + :stream stream + :msg "<>") + (princ restart stream))))))) + +;;;;; SLY-DB entry points + +(defslyfun sly-db-break-with-default-debugger (dont-unwind) + "Invoke the default debugger." + (cond (dont-unwind + (invoke-default-debugger *slynk-debugger-condition*)) + (t + (signal 'invoke-default-debugger)))) + +(defslyfun backtrace (start end) + "Return a list ((I FRAME PLIST) ...) of frames from START to END. + +I is an integer, and can be used to reference the corresponding frame +from Emacs; FRAME is a string representation of an implementation's +frame." + (loop for frame in (compute-backtrace start end) + for i from start collect + (list* i (frame-to-string frame) + (ecase (frame-restartable-p frame) + ((nil) nil) + ((t) `((:restartable t))))))) + +(defun frame-to-string (frame) + (with-string-stream (stream :length (* (or *print-lines* 1) + (or *print-right-margin* 100)) + :bindings *backtrace-printer-bindings*) + (handler-case (print-frame frame stream) + (serious-condition () + (format stream "[error printing frame]"))))) + +(defslyfun debugger-info-for-emacs (start end) + "Return debugger state, with stack frames from START to END. +The result is a list: + (condition ({restart}*) ({stack-frame}*) (cont*)) +where + condition ::= (description type [extra]) + restart ::= (name description) + stack-frame ::= (number description [plist]) + extra ::= (:references and other random things) + cont ::= continuation + plist ::= (:restartable {nil | t | :unknown}) + +condition---a pair of strings: message, and type. If show-source is +not nil it is a frame number for which the source should be displayed. + +restart---a pair of strings: restart name, and description. + +stack-frame---a number from zero (the top), and a printed +representation of the frame's call. + +continuation---the id of a pending Emacs continuation. + +Below is an example return value. In this case the condition was a +division by zero (multi-line description), and only one frame is being +fetched (start=0, end=1). + + ((\"Arithmetic error DIVISION-BY-ZERO signalled. +Operation was KERNEL::DIVISION, operands (1 0).\" + \"[Condition of type DIVISION-BY-ZERO]\") + ((\"ABORT\" \"Return to Sly toplevel.\") + (\"ABORT\" \"Return to Top-Level.\")) + ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil))) + (4))" + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (backtrace start end) + *pending-continuations*)) + +(defun nth-restart (index) + (nth index *sly-db-restarts*)) + +(defslyfun invoke-nth-restart (index) + (let ((restart (nth-restart index))) + (when restart + (let* ((prompt nil) + (*query-io* + (make-two-way-stream + (make-input-stream + (lambda () + (format nil "~a~%" + (read-from-minibuffer-in-emacs + (format nil "~a" (or prompt + "[restart prompt] :")))))) + (make-output-stream + #'(lambda (s) + (setq prompt + (concatenate 'string + (or prompt "") + s))))))) + (invoke-restart-interactively restart))))) + +(defslyfun sly-db-abort () + (invoke-restart (find 'abort *sly-db-restarts* :key #'restart-name))) + +(defslyfun sly-db-continue () + (continue)) + +(defun coerce-to-condition (datum args) + (etypecase datum + (string (make-condition 'simple-error :format-control datum + :format-arguments args)) + (symbol (apply #'make-condition datum args)))) + +(defslyfun simple-break (&optional (datum "Interrupt from Emacs") &rest args) + (with-simple-restart (continue "Continue from break.") + (invoke-sly-debugger (coerce-to-condition datum args)))) + +;; FIXME: (last (compute-restarts)) looks dubious. +(defslyfun throw-to-toplevel () + "Invoke the ABORT-REQUEST restart abort an RPC from Emacs. +If we are not evaluating an RPC then ABORT instead." + (let ((restart (or (and *sly-db-quit-restart* + (find-restart *sly-db-quit-restart*)) + (car (last (compute-restarts)))))) + (cond (restart (invoke-restart restart)) + (t (format nil "Restart not active [~s]" *sly-db-quit-restart*))))) + +(defslyfun invoke-nth-restart-for-emacs (sly-db-level n) + "Invoke the Nth available restart. +SLY-DB-LEVEL is the debug level when the request was made. If this +has changed, ignore the request." + (when (= sly-db-level *sly-db-level*) + (invoke-nth-restart n))) + +(defun wrap-sly-db-vars (form) + `(let ((*sly-db-level* ,*sly-db-level*)) + ,form)) + +(defun eval-in-frame-aux (frame string package print) + (let* ((form (wrap-sly-db-vars (parse-string string package))) + (values (multiple-value-list (eval-in-frame form frame)))) + (with-buffer-syntax (package) + (funcall print values)))) + +(defslyfun eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'echo-for-emacs)) + +(defslyfun pprint-eval-string-in-frame (string frame package) + (eval-in-frame-aux frame string package #'slynk-pprint-values)) + +(defslyfun frame-package-name (frame) + (let ((pkg (frame-package frame))) + (cond (pkg (package-name pkg)) + (t (with-buffer-syntax () (package-name *package*)))))) + +(defslyfun frame-locals-and-catch-tags (index) + "Return a list (LOCALS TAGS) for vars and catch tags in the frame INDEX. +LOCALS is a list of the form ((&key NAME ID VALUE) ...). +TAGS has is a list of strings." + (list (frame-locals-for-emacs index) + (mapcar #'to-string (frame-catch-tags index)))) + +(defun frame-locals-for-emacs (index) + (loop for var in (frame-locals index) + collect + (destructuring-bind (&key name id value) var + (list :name (let ((*package* (or (frame-package index) *package*))) + (prin1-to-string name)) + :id id + :value + (let ((*slynk-pprint-bindings* + (append *slynk-pprint-bindings* + *backtrace-printer-bindings*))) + (slynk-pprint value)))))) + +(defslyfun sly-db-disassemble (index) + (with-output-to-string (*standard-output*) + (disassemble-frame index))) + +(defslyfun sly-db-return-from-frame (index string) + (let ((form (from-string string))) + (to-string (multiple-value-list (return-from-frame index form))))) + +(defslyfun sly-db-break (name) + (with-buffer-syntax () + (sly-db-break-at-start (read-from-string name)))) + +(defmacro define-stepper-function (name backend-function-name) + `(defslyfun ,name (frame) + (cond ((sly-db-stepper-condition-p *slynk-debugger-condition*) + (setq *sly-db-stepping-p* t) + (,backend-function-name)) + ((find-restart 'continue) + (activate-stepping frame) + (setq *sly-db-stepping-p* t) + (continue)) + (t + (error "Not currently single-stepping, ~ +and no continue restart available."))))) + +(define-stepper-function sly-db-step sly-db-step-into) +(define-stepper-function sly-db-next sly-db-step-next) +(define-stepper-function sly-db-out sly-db-step-out) + +(defslyfun toggle-break-on-signals () + (setq *break-on-signals* (not *break-on-signals*)) + (format nil "*break-on-signals* = ~a" *break-on-signals*)) + +(defslyfun sdlb-print-condition () + (princ-to-string *slynk-debugger-condition*)) + + +;;;; Compilation Commands. + +(defstruct (compilation-result (:type list)) + (type :compilation-result) + notes + (successp nil :type boolean) + (duration 0.0 :type float) + (loadp nil :type boolean) + (faslfile nil :type (or null string))) + +(defun measure-time-interval (fun) + "Call FUN and return the first return value and the elapsed time. +The time is measured in seconds." + (declare (type function fun)) + (let ((before (get-internal-real-time))) ; + (values + (funcall fun) + (/ (- (get-internal-real-time) before) + (coerce internal-time-units-per-second 'float))))) + +(defun make-compiler-note (condition) + "Make a compiler note data structure from a compiler-condition." + (declare (type compiler-condition condition)) + (list* :message (message condition) + :severity (severity condition) + :location (location condition) + :references (references condition) + (let ((s (source-context condition))) + (if s (list :source-context s))))) + +(defun collect-notes (function) + (let ((notes '())) + (multiple-value-bind (result seconds) + (handler-bind ((compiler-condition + (lambda (c) (push (make-compiler-note c) notes)))) + (measure-time-interval + (lambda () + ;; To report location of error-signaling toplevel forms + ;; for errors in EVAL-WHEN or during macroexpansion. + (restart-case (multiple-value-list (funcall function)) + (abort () :report "Abort compilation." (list nil)))))) + (destructuring-bind (successp &optional loadp faslfile) result + (let ((faslfile (etypecase faslfile + (null nil) + (pathname (pathname-to-filename faslfile))))) + (make-compilation-result :notes (reverse notes) + :duration seconds + :successp (if successp t) + :loadp (if loadp t) + :faslfile faslfile)))))) + +(defun slynk-compile-file* (pathname load-p &rest options &key policy + &allow-other-keys) + (multiple-value-bind (output-pathname warnings? failure?) + (slynk-compile-file pathname + (fasl-pathname pathname options) + nil + (or (guess-external-format pathname) + :default) + :policy policy) + (declare (ignore warnings?)) + (values t (not failure?) load-p output-pathname))) + +(defvar *compile-file-for-emacs-hook* '(slynk-compile-file*)) + +(defslyfun compile-file-for-emacs (filename load-p &rest options) + "Compile FILENAME and, when LOAD-P, load the result. +Record compiler notes signalled as `compiler-condition's." + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((pathname (filename-to-pathname filename)) + (*compile-print* nil) + (*compile-verbose* t)) + (loop for hook in *compile-file-for-emacs-hook* + do + (multiple-value-bind (tried success load? output-pathname) + (apply hook pathname load-p options) + (when tried + (return (values success load? output-pathname)))))))))) + +;; FIXME: now that *compile-file-for-emacs-hook* is there this is +;; redundant and confusing. +(defvar *fasl-pathname-function* nil + "In non-nil, use this function to compute the name for fasl-files.") + +(defun pathname-as-directory (pathname) + (append (pathname-directory pathname) + (when (pathname-name pathname) + (list (file-namestring pathname))))) + +(defun compile-file-output (file directory) + (make-pathname :directory (pathname-as-directory directory) + :defaults (compile-file-pathname file))) + +(defun fasl-pathname (input-file options) + (cond (*fasl-pathname-function* + (funcall *fasl-pathname-function* input-file options)) + ((getf options :fasl-directory) + (let ((dir (getf options :fasl-directory))) + (assert (char= (aref dir (1- (length dir))) #\/)) + (compile-file-output input-file dir))) + (t + (compile-file-pathname input-file)))) + +(defslyfun compile-string-for-emacs (string buffer position filename policy) + "Compile STRING (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (let* ((offset (cadr (assoc :position position))) + (line-column (cdr (assoc :line position))) + (line (first line-column)) + (column (second line-column))) + (with-buffer-syntax () + (collect-notes + (lambda () + (let ((*compile-print* nil) + (*compile-verbose* nil) + (*load-verbose* nil)) + (slynk-compile-string string + :buffer buffer + :position offset + :filename filename + :line line + :column column + :policy policy))))))) + +(defslyfun compile-multiple-strings-for-emacs (strings policy) + "Compile STRINGS (exerpted from BUFFER at POSITION). +Record compiler notes signalled as `compiler-condition's." + (loop for (string buffer package position filename) in strings collect + (collect-notes + (lambda () + (with-buffer-syntax (package) + (let ((*compile-print* t) (*compile-verbose* nil)) + (slynk-compile-string string + :buffer buffer + :position position + :filename filename + :policy policy))))))) + +(defun file-newer-p (new-file old-file) + "Returns true if NEW-FILE is newer than OLD-FILE." + (> (file-write-date new-file) (file-write-date old-file))) + +(defun requires-compile-p (source-file) + (let ((fasl-file (probe-file (compile-file-pathname source-file)))) + (or (not fasl-file) + (file-newer-p source-file fasl-file)))) + +(defslyfun compile-file-if-needed (filename loadp) + (let ((pathname (filename-to-pathname filename))) + (cond ((requires-compile-p pathname) + (compile-file-for-emacs pathname loadp)) + (t + (collect-notes + (lambda () + (or (not loadp) + (load (compile-file-pathname pathname))))))))) + + +;;;; Loading + +(defslyfun load-file (filename) + (to-string (load (filename-to-pathname filename)))) + + +;;;;; slynk-require + +(defvar *module-loading-method* (find-if #'find-package '(:slynk-loader :asdf)) + "Keyword naming the module-loading method. + +SLY's own `slynk-loader.lisp' is tried first, then ASDF") + +(defvar *asdf-load-in-progress* nil + "Set to t if inside a \"ASDF:LOAD-SYSTEM\" operation. +Introduced to prevent problematic recursive ASDF loads, but going away +soon once non-ASDF loading is removed. (see github#134)") + +(defgeneric require-module (method module) + (:documentation + "Use METHOD to load MODULE. +Receives a module name as argument and should return non-nil if it +managed to load it.") + (:method ((method (eql :slynk-loader)) module) + (funcall (intern "REQUIRE-MODULE" :slynk-loader) module)) + (:method ((method (eql :asdf)) module) + (unless *asdf-load-in-progress* + (let ((*asdf-load-in-progress* t)) + (funcall (intern "LOAD-SYSTEM" :asdf) module))))) + +(defun add-to-load-path-1 (path load-path-var) + (pushnew path (symbol-value load-path-var) :test #'equal)) + +(defgeneric add-to-load-path (method path) + (:documentation + "Using METHOD, consider PATH when searching for modules.") + (:method ((method (eql :slynk-loader)) path) + (add-to-load-path-1 path (intern "*LOAD-PATH*" :slynk-loader))) + (:method ((method (eql :asdf)) path) + (add-to-load-path-1 path (intern "*CENTRAL-REGISTRY*" :asdf)))) + +(defvar *slynk-require-hook* '() + "Functions run after SLYNK-REQUIRE. Called with new modules.") + +(defslyfun slynk-require (modules) + "Load each module in MODULES. + +MODULES is a list of strings designators or a single string +designator. Returns a list of all modules available." + (let ((loaded)) + (dolist (module (ensure-list modules)) + (with-simple-restart (continue "Continue without SLY contrib ~a" module) + (funcall #'require-module *module-loading-method* module) + (push module loaded) + (pushnew (string-upcase module) *modules* :test #'equal)) + (loop for fn in *slynk-require-hook* + do (funcall fn loaded))) + (list *modules* loaded))) + +(defslyfun slynk-add-load-paths (paths) + (dolist (path paths) + (funcall #'add-to-load-path *module-loading-method* (pathname path)))) + + +;;;; Macroexpansion + +(defvar *macroexpand-printer-bindings* + '((*print-circle* . nil) + (*print-pretty* . t) + (*print-escape* . t) + (*print-lines* . nil) + (*print-level* . nil) + (*print-length* . nil) + (*print-case* . :downcase)) + "Pretty-pretty bindings to use when expanding macros") + +(defun apply-macro-expander (expander string) + (with-buffer-syntax () + (let ((expansion (funcall expander (from-string string)))) + (with-bindings *macroexpand-printer-bindings* + (prin1-to-string expansion))))) + +(defslyfun slynk-macroexpand-1 (string) + (apply-macro-expander #'macroexpand-1 string)) + +(defslyfun slynk-macroexpand (string) + (apply-macro-expander #'macroexpand string)) + +(defslyfun slynk-macroexpand-all (string) + (apply-macro-expander #'macroexpand-all string)) + +(defslyfun slynk-compiler-macroexpand-1 (string) + (apply-macro-expander #'compiler-macroexpand-1 string)) + +(defslyfun slynk-compiler-macroexpand (string) + (apply-macro-expander #'compiler-macroexpand string)) + +(defslyfun slynk-expand-1 (string) + (apply-macro-expander #'expand-1 string)) + +(defslyfun slynk-expand (string) + (apply-macro-expander #'expand string)) + +(defun expand-1 (form) + (multiple-value-bind (expansion expanded?) (macroexpand-1 form) + (if expanded? + (values expansion t) + (compiler-macroexpand-1 form)))) + +(defun expand (form) + (expand-repeatedly #'expand-1 form)) + +(defun expand-repeatedly (expander form) + (loop + (multiple-value-bind (expansion expanded?) (funcall expander form) + (unless expanded? (return expansion)) + (setq form expansion)))) + +(defslyfun slynk-format-string-expand (string) + (apply-macro-expander #'format-string-expand string)) + +(defslyfun disassemble-form (form) + (with-buffer-syntax () + (with-output-to-string (*standard-output*) + (let ((*print-readably* nil)) + (disassemble (eval (read-from-string form))))))) + + +;;;; Simple arglist display + +(defslyfun operator-arglist (name package) + (ignore-errors + (let ((args (arglist (parse-symbol name (guess-buffer-package package))))) + (cond ((eq args :not-available) nil) + (t (princ-to-string (cons name args))))))) + + +;;;; Documentation + +(defun map-if (test fn &rest lists) + "Like (mapcar FN . LISTS) but only call FN on objects satisfying TEST. +Example: +\(map-if #'oddp #'- '(1 2 3 4 5)) => (-1 2 -3 4 -5)" + (apply #'mapcar + (lambda (x) (if (funcall test x) (funcall fn x) x)) + lists)) + +(defun listify (f) + "Return a function like F, but which returns any non-null value +wrapped in a list." + (lambda (x) + (let ((y (funcall f x))) + (and y (list y))))) + +(defun call-with-describe-settings (fn) + (let ((*print-readably* nil)) + (funcall fn))) + +(defmacro with-describe-settings ((&rest _) &body body) + (declare (ignore _)) + `(call-with-describe-settings (lambda () ,@body))) + +(defun describe-to-string (object) + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe object)))) + +(defslyfun describe-symbol (symbol-name) + (with-buffer-syntax () + (describe-to-string (parse-symbol-or-lose symbol-name)))) + +(defslyfun describe-function (name) + (with-buffer-syntax () + (let ((symbol (parse-symbol-or-lose name))) + (describe-to-string (or (macro-function symbol) + (symbol-function symbol)))))) + +(defslyfun describe-definition-for-emacs (name kind) + (with-buffer-syntax () + (with-describe-settings () + (with-output-to-string (*standard-output*) + (describe-definition (parse-symbol-or-lose name) kind))))) + +(defslyfun documentation-symbol (symbol-name) + (with-buffer-syntax () + (multiple-value-bind (sym foundp) (parse-symbol symbol-name) + (if foundp + (let ((vdoc (documentation sym 'variable)) + (fdoc (documentation sym 'function))) + (with-output-to-string (string) + (format string "Documentation for the symbol ~a:~2%" sym) + (unless (or vdoc fdoc) + (format string "Not documented." )) + (when vdoc + (format string "Variable:~% ~a~2%" vdoc)) + (when fdoc + (format string "Function:~% Arglist: ~a~2% ~a" + (slynk-backend:arglist sym) + fdoc)))) + (format nil "No such symbol, ~a." symbol-name))))) + + +;;;; Package Commands + +(defslyfun list-all-package-names (&optional nicknames) + "Return a list of all package names. +Include the nicknames if NICKNAMES is true." + (mapcar #'unparse-name + (if nicknames + (mapcan #'package-names (list-all-packages)) + (mapcar #'package-name (list-all-packages))))) + + +;;;; Tracing + +;; Use eval for the sake of portability... +(defun tracedp (fspec) + (member fspec (eval '(trace)))) + +(defvar *after-toggle-trace-hook* nil + "Hook called whenever a SPEC is traced or untraced. + +If non-nil, called with two arguments SPEC and TRACED-P." ) +(defslyfun slynk-toggle-trace (spec-string) + (let* ((spec (from-string spec-string)) + (retval (cond ((consp spec) ; handle complicated cases in the backend + (toggle-trace spec)) + ((tracedp spec) + (eval `(untrace ,spec)) + (format nil "~S is now untraced." spec)) + (t + (eval `(trace ,spec)) + (format nil "~S is now traced." spec)))) + (traced-p (let* ((tosearch "is now traced.") + (start (- (length retval) + (length tosearch))) + (end (+ start (length tosearch)))) + (search tosearch (subseq retval start end)))) + (hook-msg (when *after-toggle-trace-hook* + (funcall *after-toggle-trace-hook* + spec + traced-p)))) + (if hook-msg + (format nil "~a~%(also ~a)" retval hook-msg) + retval))) + +(defslyfun untrace-all () + (untrace)) + + +;;;; Undefing + +(defslyfun undefine-function (fname-string) + (let ((fname (from-string fname-string))) + (format nil "~S" (fmakunbound fname)))) + +(defun read-as-function (name) + (eval (from-string (format nil "(function ~A)" name)))) + +(defslyfun remove-method-by-name (generic-name qualifiers specializers) + "Remove GENERIC-NAME's method with QUALIFIERS and SPECIALIZERS." + (let* ((generic-function (read-as-function generic-name)) + (qualifiers (mapcar #'from-string qualifiers)) + (specializers (mapcar #'from-string specializers)) + (method (find-method generic-function qualifiers specializers))) + (remove-method generic-function method) + t)) + +(defslyfun generic-method-specs (generic-name) + "Compute ((QUALIFIERS SPECIALIZERS)...) for methods of GENERIC-NAME's gf. +QUALIFIERS and SPECIALIZERS are lists of strings." + (mapcar + (lambda (method) + (list (mapcar #'prin1-to-string (slynk-mop:method-qualifiers method)) + (mapcar (lambda (specializer) + (if (typep specializer 'slynk-mop:eql-specializer) + (format nil "(eql ~A)" + (slynk-mop:eql-specializer-object specializer)) + (prin1-to-string (class-name specializer)))) + (slynk-mop:method-specializers method)))) + (slynk-mop:generic-function-methods (read-as-function generic-name)))) + +(defslyfun unintern-symbol (name package) + (let ((pkg (guess-package package))) + (cond ((not pkg) (format nil "No such package: ~s" package)) + (t + (multiple-value-bind (sym found) (parse-symbol name pkg) + (case found + ((nil) (format nil "~s not in package ~s" name package)) + (t + (unintern sym pkg) + (format nil "Uninterned symbol: ~s" sym)))))))) + +(defslyfun slynk-delete-package (package-name) + (let ((pkg (or (guess-package package-name) + (error "No such package: ~s" package-name)))) + (delete-package pkg) + nil)) + +;;;; Source Locations + +(defslyfun find-definition-for-thing (thing) + (find-source-location thing)) + +(defslyfun find-source-location-for-emacs (spec) + (find-source-location (value-spec-ref spec))) + +(defun value-spec-ref (spec) + (destructure-case spec + ((:string string package) + (with-buffer-syntax (package) + (eval (read-from-string string)))) + ((:inspector part) + (inspector-nth-part part)) + ((:sly-db frame var) + (frame-var-value frame var)))) + +(defvar *find-definitions-right-trim* ",:.>") +(defvar *find-definitions-left-trim* "#:<") + +(defun find-definitions-find-symbol-or-package (name) + (flet ((do-find (name) + (multiple-value-bind (symbol found name) + (with-buffer-syntax () + (parse-symbol name)) + (cond (found + (return-from find-definitions-find-symbol-or-package + (values symbol found))) + ;; Packages are not named by symbols, so + ;; not-interned symbols can refer to packages + ((find-package name) + (return-from find-definitions-find-symbol-or-package + (values (make-symbol name) t))))))) + (do-find name) + (do-find (string-right-trim *find-definitions-right-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* name)) + (do-find (string-left-trim *find-definitions-left-trim* + (string-right-trim + *find-definitions-right-trim* name))) + ;; Not exactly robust + (when (and (eql (search "(setf " name :test #'char-equal) 0) + (char= (char name (1- (length name))) #\))) + (multiple-value-bind (symbol found) + (with-buffer-syntax () + (parse-symbol (subseq name (length "(setf ") + (1- (length name))))) + (when found + (values `(setf ,symbol) t)))))) + +(defslyfun find-definitions-for-emacs (name) + "Return a list ((DSPEC LOCATION) ...) of definitions for NAME. +DSPEC is a string and LOCATION a source location. NAME is a string." + (multiple-value-bind (symbol found) + (find-definitions-find-symbol-or-package name) + (when found + (mapcar #'xref>elisp (find-definitions symbol))))) + +;;; Generic function so contribs can extend it. +(defgeneric xref-doit (type thing) + (:method (type thing) + (declare (ignore type thing)) + :not-implemented)) + +(macrolet ((define-xref-action (xref-type handler) + `(defmethod xref-doit ((type (eql ,xref-type)) thing) + (declare (ignorable type)) + (funcall ,handler thing)))) + (define-xref-action :calls #'who-calls) + (define-xref-action :calls-who #'calls-who) + (define-xref-action :references #'who-references) + (define-xref-action :binds #'who-binds) + (define-xref-action :sets #'who-sets) + (define-xref-action :macroexpands #'who-macroexpands) + (define-xref-action :specializes #'who-specializes) + (define-xref-action :callers #'list-callers) + (define-xref-action :callees #'list-callees)) + +(defslyfun xref (type name) + (multiple-value-bind (sexp error) (ignore-errors (from-string name)) + (unless error + (let ((xrefs (xref-doit type sexp))) + (if (eq xrefs :not-implemented) + :not-implemented + (mapcar #'xref>elisp xrefs)))))) + +(defslyfun xrefs (types name) + (loop for type in types + for xrefs = (xref type name) + when (and (not (eq :not-implemented xrefs)) + (not (null xrefs))) + collect (cons type xrefs))) + +(defun xref>elisp (xref) + (destructuring-bind (name loc) xref + (list (to-string name) loc))) + + +;;;;; Lazy lists + +(defstruct (lcons (:constructor %lcons (car %cdr)) + (:predicate lcons?)) + car + (%cdr nil :type (or null lcons function)) + (forced? nil)) + +(defmacro lcons (car cdr) + `(%lcons ,car (lambda () ,cdr))) + +(defmacro lcons* (car cdr &rest more) + (cond ((null more) `(lcons ,car ,cdr)) + (t `(lcons ,car (lcons* ,cdr ,@more))))) + +(defun lcons-cdr (lcons) + (let ((cdr (lcons-%cdr lcons))) + (cond ((lcons-forced? lcons) cdr) + (t + (let ((value (funcall cdr))) + (setf (lcons-forced? lcons) t + (lcons-%cdr lcons) value)))))) + +(defun llist-range (llist start end) + (llist-take (llist-skip llist start) (- end start))) + +(defun llist-skip (lcons index) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i index) (null l)) + l))) + +(defun llist-take (lcons count) + (let ((result '())) + (do ((i 0 (1+ i)) + (l lcons (lcons-cdr l))) + ((or (= i count) + (null l))) + (push (lcons-car l) result)) + (nreverse result))) + +(defun iline (label value) + `(:line ,label ,value)) + + +;;;; Inspecting +(defvar-unbound *current-inspector* + "Current inspector, bound by EVAL-FOR-INSPECTOR, maybe to nil.") + +(defvar-unbound *target-inspector* + "Target inspector, bound by EVAL-FOR-INSPECTOR, maybe to nil.") + +(defun current-inspector () + (or (and (boundp '*current-inspector*) + *current-inspector*) + (find-inspector "default") + (make-instance 'inspector :name "default"))) + +(defun target-inspector () + (or (and (boundp '*target-inspector*) + *target-inspector*) + (current-inspector))) + + +(defvar *inspector-printer-bindings* + '((*print-lines* . 1) + (*print-right-margin* . 75) + (*print-pretty* . t) + (*print-readably* . nil))) + +(defvar *inspector-verbose-printer-bindings* + '((*print-escape* . t) + (*print-circle* . t) + (*print-array* . nil))) + +(defclass inspector () + ((verbose-p :initform nil :accessor inspector-verbose-p) + (history :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor inspector-%history) + (name :initarg :name :initform (error "Name this INSPECTOR!") :accessor inspector-name))) + +(defmethod print-object ((i inspector) s) + (print-unreadable-object (i s :type t) + (format s "~a/~a" (inspector-name i) (length (inspector-%history i))))) + +(defmethod initialize-instance :after ((i inspector) &key name) + (assert (not (find-inspector name)) nil "Already have an inspector named ~a" name) + (push i (connection-inspectors *emacs-connection*))) + +(defun find-inspector (name) + (find name (connection-inspectors *emacs-connection*) + :key #'inspector-name :test #'string=)) + +(defstruct inspector-state) +(defstruct (istate (:conc-name istate.) (:include inspector-state)) + object + (parts (make-array 10 :adjustable t :fill-pointer 0)) + (actions (make-array 10 :adjustable t :fill-pointer 0)) + metadata + content + serial) + +(defun ensure-istate-metadata (o indicator default) + (with-struct (istate. object metadata) (current-istate) + (assert (eq object o)) + (let ((data (getf metadata indicator default))) + (setf (getf metadata indicator) data) + data))) + +(defun current-istate (&optional (inspector (current-inspector))) + (let* ((history (inspector-%history inspector))) + (and (plusp (length history)) + (aref history (1- (length history)))))) + +(defun reset-inspector (&optional (inspector (current-inspector))) + #+sbcl + ;; FIXME: On SBCL, for some silly reason, this is needed to lose the + ;; references to the history's objects (github##568) + (loop with hist = (inspector-%history inspector) + for i from 0 below (array-dimension hist 0) + do (setf (aref hist i) nil)) + (setf (inspector-%history inspector) + (make-array 10 :adjustable t :fill-pointer 0))) + +(defslyfun init-inspector (string) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY inspection request.") + (inspect-object (eval (read-from-string string)))))) + +(defun inspect-object (o) + (let* ((inspector (target-inspector)) + (history (inspector-%history inspector)) + (istate (make-istate :object o))) + (vector-push-extend istate history) + (let ((*current-inspector* inspector)) + ;; HACK! because EMACS-INSPECT may call ENSURE-ISTATE-METADATA + ;; which expects its object to be the current istate's objects. + (setf (istate.content istate) + (emacs-inspect o))) + (vector-push-extend :break-history history) + (decf (fill-pointer history)) + (istate>elisp istate))) + +(defun istate>elisp (istate) + (list :title (prepare-title istate) + :id (assign-index (istate.object istate) (istate.parts istate)) + :content (prepare-range istate 0 500) + ;; :serial (istate.serial istate) + )) + +(defun prepare-title (istate) + (if (inspector-verbose-p (current-inspector)) + (with-bindings *inspector-verbose-printer-bindings* + (to-string (istate.object istate))) + (with-string-stream (stream :length 200 + :bindings *inspector-printer-bindings*) + (print-unreadable-object + ((istate.object istate) stream :type t :identity t))))) + +(defun prepare-range (istate start end) + (let* ((range (content-range (istate.content istate) start end)) + (ps (loop for part in range append (prepare-part part istate)))) + (list ps + (if (< (length ps) (- end start)) + (+ start (length ps)) + (+ end 1000)) + start end))) + +(defun prepare-part (part istate) + (let ((newline '#.(string #\newline))) + (etypecase part + (string (list part)) + (cons (destructure-case part + ((:newline) (list newline)) + ((:value obj &optional str) + (list (value-part obj str (istate.parts istate)))) + ((:label &rest strs) + (list (list :label (apply #'cat (mapcar #'string strs))))) + ((:action label lambda &key (refreshp t)) + (list (action-part label lambda refreshp + (istate.actions istate)))) + ((:line label value) + (list (princ-to-string label) ": " + (value-part value nil (istate.parts istate)) + newline))))))) + +(defun value-part (object string parts) + (list :value + (or string (print-part-to-string object)) + (assign-index object parts))) + +(defun action-part (label lambda refreshp actions) + (list :action label (assign-index (list lambda refreshp) actions))) + +(defun assign-index (object vector) + (let ((index (fill-pointer vector))) + (vector-push-extend object vector) + index)) + +(defun print-part-to-string (value) + (let* ((*print-readably* nil) + (string (slynk-pprint-to-line value)) + (pos (position value + (inspector-%history (current-inspector)) + :key #'istate.object))) + (if pos + (format nil "@~D=~A" pos string) + string))) + +(defun content-range (list start end) + (typecase list + (list (let ((len (length list))) + (subseq list start (min len end)))) + (lcons (llist-range list start end)))) + +(defslyfun inspector-nth-part (index) + "Return the current inspector's INDEXth part. +The second value indicates if that part exists at all." + (let* ((parts (istate.parts (current-istate))) + (foundp (< index (length parts)))) + (values (and foundp (aref parts index)) + foundp))) + +(defslyfun inspector-nth-part-or-lose (index) + "Return the current inspector's INDEXth part. +The second value indicates if that part exists at all." + (multiple-value-bind (part foundp) + (inspector-nth-part index) + (if foundp part (error "No part with index ~a" index)))) + +(defslyfun inspect-nth-part (index) + (with-buffer-syntax () + (inspect-object (inspector-nth-part index)))) + +(defslyfun inspector-range (from to) + (prepare-range (current-istate) from to)) + +(defslyfun inspector-call-nth-action (index &rest args) + (destructuring-bind (fun refreshp) (aref (istate.actions (current-istate)) index) + (apply fun args) + (if refreshp + (inspector-reinspect) + ;; tell emacs that we don't want to refresh the inspector buffer + nil))) + +(defslyfun inspector-pop () + "Inspect the previous object. +Return nil if there's no previous object." + (with-buffer-syntax () + (let* ((history (inspector-%history (current-inspector)))) + (when (> (length history) 1) + (decf (fill-pointer history)) + (istate>elisp (current-istate)))))) + +(defslyfun inspector-next () + "Inspect the next element in the history of inspected objects.." + (with-buffer-syntax () + (let* ((history (inspector-%history (current-inspector)))) + (when (and (< (fill-pointer history) + (array-dimension history 0)) + (istate-p (aref history (fill-pointer history)))) + (incf (fill-pointer history)) + (istate>elisp (current-istate)))))) + +(defslyfun inspector-reinspect () + (let ((istate (current-istate))) + (setf (istate.content istate) + (emacs-inspect (istate.object istate))) + (istate>elisp istate))) + +(defslyfun inspector-toggle-verbose () + "Toggle verbosity of inspected object." + (setf (inspector-verbose-p (current-inspector)) + (not (inspector-verbose-p (current-inspector)))) + (istate>elisp (current-istate))) + +(defslyfun inspector-eval (string) + (let* ((obj (istate.object (current-istate))) + (context (eval-context obj)) + (form (with-buffer-syntax ((cdr (assoc '*package* context))) + (read-from-string string))) + (ignorable (remove-if #'boundp (mapcar #'car context)))) + (to-string (eval `(let ((* ',obj) (- ',form) + . ,(loop for (var . val) in context + unless (constantp var) collect + `(,var ',val))) + (declare (ignorable . ,ignorable)) + ,form))))) + +(defslyfun inspector-history () + (slynk-pprint-to-line (inspector-%history (current-inspector)))) + +(defslyfun quit-inspector () + (reset-inspector) + nil) + +(defslyfun describe-inspectee () + "Describe the currently inspected object." + (with-buffer-syntax () + (describe-to-string (istate.object (current-istate))))) + +(defslyfun describe-inspector-part (index) + "Describe part INDEX of the currently inspected object." + (with-buffer-syntax () + (describe-to-string (inspector-nth-part index)))) + +(defslyfun pprint-inspector-part (index) + "Pretty-print part INDEX of the currently inspected object." + (with-buffer-syntax () + (slynk-pprint (inspector-nth-part index)))) + +(defslyfun inspect-in-frame (string index) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLY inspection request.") + (reset-inspector) + (inspect-object (eval-in-frame (from-string string) index))))) + +(defslyfun inspect-current-condition () + (with-buffer-syntax () + (reset-inspector) + (inspect-object *slynk-debugger-condition*))) + +(defslyfun inspect-frame-var (frame var) + (with-buffer-syntax () + (reset-inspector) + (inspect-object (frame-var-value frame var)))) + +(defslyfun pprint-frame-var (frame var) + (with-buffer-syntax () + (slynk-pprint (frame-var-value frame var)))) + +(defslyfun describe-frame-var (frame var) + (with-buffer-syntax () + (describe-to-string (frame-var-value frame var)))) + +(defslyfun eval-for-inspector (current + target + slave-slyfun &rest args) + "Call SLAVE-SLYFUN with ARGS in CURRENT inspector, open in TARGET." + (let ((*current-inspector* (and current + (or (find-inspector current) + (make-instance 'inspector :name current)))) + (*target-inspector* (and target + (or (find-inspector target) + (make-instance 'inspector :name target))))) + (apply slave-slyfun args))) + +;;;;; Lists + +(defmethod emacs-inspect ((o cons)) + (if (listp (cdr o)) + (inspect-list o) + (inspect-cons o))) + +(defun inspect-cons (cons) + (label-value-line* + ('car (car cons)) + ('cdr (cdr cons)))) + +(defun inspect-list (list) + (multiple-value-bind (length tail) (safe-length list) + (flet ((frob (title list) + (list* title '(:newline) (inspect-list-aux list)))) + (cond ((not length) + (frob "A circular list:" + (cons (car list) + (ldiff (cdr list) list)))) + ((not tail) + (frob "A proper list:" list)) + (t + (frob "An improper list:" list)))))) + +(defun inspect-list-aux (list) + (loop for i from 0 for rest on list while (consp rest) append + (if (listp (cdr rest)) + (label-value-line i (car rest)) + (label-value-line* (i (car rest)) (:tail (cdr rest)))))) + +(defun safe-length (list) + "Similar to `list-length', but avoid errors on improper lists. +Return two values: the length of the list and the last cdr. +Return NIL if LIST is circular." + (do ((n 0 (+ n 2)) ;Counter. + (fast list (cddr fast)) ;Fast pointer: leaps by 2. + (slow list (cdr slow))) ;Slow pointer: leaps by 1. + (nil) + (cond ((null fast) (return (values n nil))) + ((not (consp fast)) (return (values n fast))) + ((null (cdr fast)) (return (values (1+ n) (cdr fast)))) + ((and (eq fast slow) (> n 0)) (return nil)) + ((not (consp (cdr fast))) (return (values (1+ n) (cdr fast))))))) + +;;;;; Hashtables + +(defun hash-table-to-alist (ht) + (let ((result '())) + (maphash (lambda (key value) + (setq result (acons key value result))) + ht) + result)) + +(defmethod emacs-inspect ((ht hash-table)) + (append + (label-value-line* + ("Count" (hash-table-count ht)) + ("Size" (hash-table-size ht)) + ("Test" (hash-table-test ht)) + ("Rehash size" (hash-table-rehash-size ht)) + ("Rehash threshold" (hash-table-rehash-threshold ht))) + (let ((weakness (hash-table-weakness ht))) + (when weakness + (label-value-line "Weakness:" weakness))) + (unless (zerop (hash-table-count ht)) + `((:action "[clear hashtable]" + ,(lambda () (clrhash ht))) (:newline) + "Contents: " (:newline))) + (let ((content (hash-table-to-alist ht))) + (cond ((every (lambda (x) (typep (first x) '(or string symbol))) content) + (setf content (sort content 'string< :key #'first))) + ((every (lambda (x) (typep (first x) 'real)) content) + (setf content (sort content '< :key #'first)))) + (loop for (key . value) in content appending + `((:value ,key) " = " (:value ,value) + " " (:action "[remove entry]" + ,(let ((key key)) + (lambda () (remhash key ht)))) + (:newline)))))) + +;;;;; Arrays + +(defmethod emacs-inspect ((array array)) + (lcons* + (iline "Dimensions" (array-dimensions array)) + (iline "Element type" (array-element-type array)) + (iline "Total size" (array-total-size array)) + (iline "Adjustable" (adjustable-array-p array)) + (iline "Fill pointer" (if (array-has-fill-pointer-p array) + (fill-pointer array))) + "Contents:" '(:newline) + (labels ((k (i max) + (cond ((= i max) '()) + (t (lcons (iline i (row-major-aref array i)) + (k (1+ i) max)))))) + (k 0 (array-total-size array))))) + +;;;;; Chars + +(defmethod emacs-inspect :around (object) + (declare (ignore object)) + (with-bindings (if (inspector-verbose-p (current-inspector)) + *inspector-verbose-printer-bindings* + *inspector-printer-bindings*) + (call-next-method))) + +(defmethod emacs-inspect ((char character)) + (append + (label-value-line* + ("Char code" (char-code char)) + ("Lower cased" (char-downcase char)) + ("Upper cased" (char-upcase char))) + (if (get-macro-character char) + `("In the current readtable (" + (:value ,*readtable*) ") it is a macro character: " + (:value ,(get-macro-character char)))))) + +;;;; Thread listing + +(defvar *thread-list* () + "List of threads displayed in Emacs. We don't care a about +synchronization issues (yet). There can only be one thread listing at +a time.") + +(defslyfun list-threads () + "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). +LABELS is a list of attribute names and the remaining lists are the +corresponding attribute values per thread. +Example: + ((:id :name :status :priority) + (6 \"slynk-indentation-cache-thread\" \"Semaphore timed wait\" 0) + (5 \"reader-thread\" \"Active\" 0) + (4 \"control-thread\" \"Semaphore timed wait\" 0) + (2 \"Slynk Sentinel\" \"Semaphore timed wait\" 0) + (1 \"listener\" \"Active\" 0) + (0 \"Initial\" \"Sleep\" 0))" + (setq *thread-list* (all-threads)) + (when (and *emacs-connection* + (use-threads-p) + ;; FIXME: hardcoded thread name + (equalp (thread-name (current-thread)) "slynk-worker")) + (setf *thread-list* (delete (current-thread) *thread-list*))) + (let* ((plist (thread-attributes (car *thread-list*))) + (labels (loop for (key) on plist by #'cddr + collect key))) + `((:id :name :status ,@labels) + ,@(loop for thread in *thread-list* + for name = (thread-name thread) + for attributes = (thread-attributes thread) + collect (list* (thread-id thread) + (string name) + (thread-status thread) + (loop for label in labels + collect (getf attributes label))))))) + +(defslyfun quit-thread-browser () + (setq *thread-list* nil)) + +(defun nth-thread (index) + (nth index *thread-list*)) + +(defslyfun debug-nth-thread (index) + (let ((connection *emacs-connection*)) + (queue-thread-interrupt + (nth-thread index) + (lambda () + (with-connection (connection) + (simple-break)))))) + +(defslyfun kill-nth-thread (index) + (kill-thread (nth-thread index))) + +(defslyfun start-slynk-server-in-thread (index port-file-name) + "Interrupt the INDEXth thread and make it start a slynk server. +The server port is written to PORT-FILE-NAME." + (interrupt-thread (nth-thread index) + (lambda () + (start-server port-file-name :style nil)))) + +;;;; Class browser + +(defun mop-helper (class-name fn) + (let ((class (find-class class-name nil))) + (if class + (mapcar (lambda (x) (to-string (class-name x))) + (funcall fn class))))) + +(defslyfun mop (type symbol-name) + "Return info about classes using mop. + + When type is: + :subclasses - return the list of subclasses of class. + :superclasses - return the list of superclasses of class." + (let ((symbol (parse-symbol symbol-name *buffer-package*))) + (ecase type + (:subclasses + (mop-helper symbol #'slynk-mop:class-direct-subclasses)) + (:superclasses + (mop-helper symbol #'slynk-mop:class-direct-superclasses))))) + + +;;;; Automatically synchronized state +;;; +;;; Here we add hooks to push updates of relevant information to +;;; Emacs. + +;;;;; *FEATURES* + +(defun sync-features-to-emacs () + "Update Emacs if any relevant Lisp state has changed." + ;; FIXME: *sly-features* should be connection-local + (unless (eq *sly-features* *features*) + (setq *sly-features* *features*) + (send-to-emacs (list :new-features (features-for-emacs))))) + +(defun features-for-emacs () + "Return `*sly-features*' in a format suitable to send it to Emacs." + *sly-features*) + +(add-hook *pre-reply-hook* 'sync-features-to-emacs) + + +;;;;; Indentation of macros +;;; +;;; This code decides how macros should be indented (based on their +;;; arglists) and tells Emacs. A per-connection cache is used to avoid +;;; sending redundant information to Emacs -- we just say what's +;;; changed since last time. +;;; +;;; The strategy is to scan all symbols, pick out the macros, and look +;;; for &body-arguments. + +(defvar *configure-emacs-indentation* t + "When true, automatically send indentation information to Emacs +after each command.") + +(defslyfun update-indentation-information () + (send-to-indentation-cache `(:update-indentation-information)) + nil) + +;; This function is for *PRE-REPLY-HOOK*. +(defun sync-indentation-to-emacs () + "Send any indentation updates to Emacs via CONNECTION." + (when *configure-emacs-indentation* + (send-to-indentation-cache `(:sync-indentation ,*buffer-package*)))) + +;; Send REQUEST to the cache. If we are single threaded perform the +;; request right away, otherwise delegate the request to the +;; indentation-cache-thread. +(defun send-to-indentation-cache (request) + (let ((c *emacs-connection*)) + (etypecase c + (singlethreaded-connection + (handle-indentation-cache-request c request)) + (multithreaded-connection + (without-sly-interrupts + (send (mconn.indentation-cache-thread c) request))) + (null t)))) + +(defun indentation-cache-loop (connection) + (with-connection (connection) + (loop + (restart-case + (handle-indentation-cache-request connection (receive)) + (abort () + :report "Return to the indentation cache request handling loop."))))) + +(defun handle-indentation-cache-request (connection request) + (destructure-case request + ((:sync-indentation package) + ;; PACKAGE may have been deleted... + (when (package-name package) + (let ((fullp (need-full-indentation-update-p connection))) + (perform-indentation-update connection fullp package)))) + ((:update-indentation-information) + (perform-indentation-update connection t nil)))) + +(defun need-full-indentation-update-p (connection) + "Return true if the whole indentation cache should be updated. +This is a heuristic to avoid scanning all symbols all the time: +instead, we only do a full scan if the set of packages has changed." + (set-difference (list-all-packages) + (connection-indentation-cache-packages connection))) + +(defun perform-indentation-update (connection force package) + "Update the indentation cache in CONNECTION and update Emacs. +If FORCE is true then start again without considering the old cache." + (let ((cache (connection-indentation-cache connection))) + (when force (clrhash cache)) + (let ((delta (update-indentation/delta-for-emacs cache force package))) + (setf (connection-indentation-cache-packages connection) + (list-all-packages)) + (unless (null delta) + (setf (connection-indentation-cache connection) cache) + (send-to-emacs (list :indentation-update delta)))))) + +(defun update-indentation/delta-for-emacs (cache force package) + "Update the cache and return the changes in a (SYMBOL INDENT PACKAGES) list. +If FORCE is true then check all symbols, otherwise only check symbols +belonging to PACKAGE." + (let ((alist '())) + (flet ((consider (symbol) + (let ((indent (symbol-indentation symbol))) + (when indent + (unless (equal (gethash symbol cache) indent) + (setf (gethash symbol cache) indent) + (let ((pkgs (mapcar #'package-name + (symbol-packages symbol))) + (name (string-downcase symbol))) + (push (list name indent pkgs) alist))))))) + (cond (force + (do-all-symbols (symbol) + (consider symbol))) + ((package-name package) ; don't try to iterate over a + ; deleted package. + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (consider symbol))))) + alist))) + +(defun package-names (package) + "Return the name and all nicknames of PACKAGE in a fresh list." + (cons (package-name package) (copy-list (package-nicknames package)))) + +(defun symbol-packages (symbol) + "Return the packages where SYMBOL can be found." + (let ((string (string symbol))) + (loop for p in (list-all-packages) + when (eq symbol (find-symbol string p)) + collect p))) + +(defun cl-symbol-p (symbol) + "Is SYMBOL a symbol in the COMMON-LISP package?" + (eq (symbol-package symbol) cl-package)) + +(defun known-to-emacs-p (symbol) + "Return true if Emacs has special rules for indenting SYMBOL." + (cl-symbol-p symbol)) + +(defun symbol-indentation (symbol) + "Return a form describing the indentation of SYMBOL. +The form is to be used as the `sly-common-lisp-indent-function' property +in Emacs." + (if (and (macro-function symbol) + (not (known-to-emacs-p symbol))) + (let ((arglist (arglist symbol))) + (etypecase arglist + ((member :not-available) + nil) + (list + (macro-indentation arglist)))) + nil)) + +(defun macro-indentation (arglist) + (if (well-formed-list-p arglist) + (position '&body (remove '&optional (clean-arglist arglist))) + nil)) + +(defun clean-arglist (arglist) + "Remove &whole, &enviroment, and &aux elements from ARGLIST." + (cond ((null arglist) '()) + ((member (car arglist) '(&whole &environment)) + (clean-arglist (cddr arglist))) + ((eq (car arglist) '&aux) + '()) + (t (cons (car arglist) (clean-arglist (cdr arglist)))))) + +(defun well-formed-list-p (list) + "Is LIST a proper list terminated by NIL?" + (typecase list + (null t) + (cons (well-formed-list-p (cdr list))) + (t nil))) + +(defun print-indentation-lossage (&optional (stream *standard-output*)) + "Return the list of symbols whose indentation styles collide incompatibly. +Collisions are caused because package information is ignored." + (let ((table (make-hash-table :test 'equal))) + (flet ((name (s) (string-downcase (symbol-name s)))) + (do-all-symbols (s) + (setf (gethash (name s) table) + (cons s (symbol-indentation s)))) + (let ((collisions '())) + (do-all-symbols (s) + (let* ((entry (gethash (name s) table)) + (owner (car entry)) + (indent (cdr entry))) + (unless (or (eq s owner) + (equal (symbol-indentation s) indent) + (and (not (fboundp s)) + (null (macro-function s)))) + (pushnew owner collisions) + (pushnew s collisions)))) + (if (null collisions) + (format stream "~&No worries!~%") + (format stream "~&Symbols with collisions:~%~{ ~S~%~}" + collisions)))))) + +;;; FIXME: it's too slow on CLASP right now, remove once it's fast enough. +#-clasp +(add-hook *pre-reply-hook* 'sync-indentation-to-emacs) + + +;;;; Testing + +(defslyfun io-speed-test (&optional (n 1000) (m 1)) + (let* ((s *standard-output*) + (*trace-output* (make-broadcast-stream s *log-output*))) + (time (progn + (dotimes (i n) + (format s "~D abcdefghijklm~%" i) + (when (zerop (mod n m)) + (finish-output s))) + (finish-output s) + (when *emacs-connection* + (eval-in-emacs '(message "done."))))) + (terpri *trace-output*) + (finish-output *trace-output*) + nil)) + +(defslyfun flow-control-test (n delay) + (let ((stream (make-output-stream + (let ((conn *emacs-connection*)) + (lambda (string) + (declare (ignore string)) + (with-connection (conn) + (send-to-emacs `(:test-delay ,delay)))))))) + (dotimes (i n) + (print i stream) + (force-output stream) + (background-message "flow-control-test: ~d" i)))) + + +;;;; The "official" API + +(defpackage :slynk-api (:use)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((api '(#:*emacs-connection* + #:*m-x-sly-from-emacs* + #:default-connection + ;; + #:channel + #:channel-id + #:channel-thread-id + #:close-channel + #:define-channel-method + #:find-channel + #:send-to-remote-channel + #:*channel* + ;; + #:listener + #:with-listener-bindings + #:saving-listener-bindings + #:flush-listener-streams + #:default-listener + #:close-listener + ;; + #:add-hook + #:*connection-closed-hook* + #:*after-init-hook* + #:*new-connection-hook* + #:*pre-reply-hook* + #:*after-toggle-trace-hook* + #:*eval-for-emacs-wrappers* + #:*debugger-extra-options* + #:*buffer-readtable* + ;; + #:defslyfun + #:destructure-case + #:log-event + #:process-requests + #:use-threads-p + #:wait-for-event + #:with-bindings + #:with-connection + #:with-top-level-restart + #:with-sly-interrupts + #:with-buffer-syntax + #:with-retry-restart + #:*loaded-user-init-file* + #:load-user-init-file + #:make-thread-bindings-aware-lambda + ;; + #:package-string-for-prompt + ;; + #:*slynk-wire-protocol-version* + ;; + #:*slynk-require-hook* + ;; + #:present-for-emacs + ;; packages + ;; + #:cl-package + #:+keyword-package+ + #:guess-package + #:guess-buffer-package + #:*exclude-symbol-functions* + #:*buffer-package* + #:*slynk-io-package* + #:parse-package + ;; symbols + ;; + #:tokenize-symbol + #:untokenize-symbol + #:symbol-external-p + #:unparse-name + #:excluded-from-searches-p + ;; + ;; + #:slynk-pprint + #:slynk-pprint-values + #:slynk-pprint-to-line + ;; + ;; + #:background-message + #:map-if))) + (loop for sym in api + for slynk-api-sym = (intern (string sym) :slynk-api) + for slynk-sym = (intern (string sym) :slynk) + do (unintern slynk-api-sym :slynk-api) + (import slynk-sym :slynk-api) + (export slynk-sym :slynk-api)))) + + +;;;; INIT, as called from the slynk-loader.lisp and ASDF's loaders +;;;; +(defvar *loaded-user-init-file* nil + "User init file actually loaded from user's home, if any.") +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (find-if (lambda (homedir-file) + (load (merge-pathnames (user-homedir-pathname) + homedir-file) + :if-does-not-exist nil)) + (list (make-pathname :name ".slynk" :type "lisp") + (make-pathname :name ".slynkrc")))) + +(defun init () + (unless (member :slynk *features*) + (pushnew :slynk *features*)) + (setq *loaded-user-init-file* (load-user-init-file)) + (run-hook *after-init-hook*)) + +;; Local Variables: +;; sly-load-failed-fasl: ask +;; End: blob - /dev/null blob + befe5d7eea4c80c14bdcdc3744399c8e504dba99 (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/start-slynk.lisp @@ -0,0 +1,21 @@ +;;; This file is intended to be loaded by an implementation to +;;; get a running slynk server +;;; e.g. sbcl --load start-slynk.lisp +;;; +;;; Default port is 4005 + +;;; For additional slynk-side configurations see +;;; 6.2 section of the Slime user manual. + +(load (make-pathname :name "slynk-loader" :type "lisp" + :defaults *load-truename*)) + +(slynk-loader:init + :delete nil ; delete any existing SLYNK packages + :reload nil) ; reload SLYNK, even if the SLYNK package already exists + + +(slynk:create-server :port 4005 + ;; if non-nil the connection won't be closed + ;; after connecting + :dont-close t) blob - /dev/null blob + cb3977538824a44bf3d469b4c3b92c43a3bccf4c (mode 644) --- /dev/null +++ elpa/sly-20250522.2241/slynk/xref.lisp @@ -0,0 +1,2906 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; -*- +;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz +;;; xref.lisp + +;;; **************************************************************** +;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp +;;; **************************************************************** +;;; +;;; The List Callers system is a portable Common Lisp cross referencing +;;; utility. It grovels over a set of files and compiles a database of the +;;; locations of all references for each symbol used in the files. +;;; List Callers is similar to the Symbolics Who-Calls and the +;;; Xerox Masterscope facilities. +;;; +;;; When you change a function or variable definition, it can be useful +;;; to know its callers, in order to update each of them to the new +;;; definition. Similarly, having a graphic display of the structure +;;; (e.g., call graph) of a program can help make undocumented code more +;;; understandable. This static code analyzer facilitates both capabilities. +;;; The database compiled by xref is suitable for viewing by a graphical +;;; browser. (Note: the reference graph is not necessarily a DAG. Since many +;;; graphical browsers assume a DAG, this will lead to infinite loops. +;;; Some code which is useful in working around this problem is included, +;;; as well as a sample text-indenting outliner and an interface to Bates' +;;; PSGraph Postscript Graphing facility.) +;;; +;;; Written by Mark Kantrowitz, July 1990. +;;; +;;; Address: School of Computer Science +;;; Carnegie Mellon University +;;; Pittsburgh, PA 15213 +;;; +;;; Copyright (c) 1990. All rights reserved. +;;; +;;; See general license below. +;;; + +;;; **************************************************************** +;;; General License Agreement and Lack of Warranty ***************** +;;; **************************************************************** +;;; +;;; This software is distributed in the hope that it will be useful (both +;;; in and of itself and as an example of lisp programming), but WITHOUT +;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for +;;; the consequences of using it or for whether it serves any particular +;;; purpose or works at all. No warranty is made about the software or its +;;; performance. +;;; +;;; Use and copying of this software and the preparation of derivative +;;; works based on this software are permitted, so long as the following +;;; conditions are met: +;;; o The copyright notice and this entire notice are included intact +;;; and prominently carried on all copies and supporting documentation. +;;; o No fees or compensation are charged for use, copies, or +;;; access to this software. You may charge a nominal +;;; distribution fee for the physical act of transferring a +;;; copy, but you may not charge for the program itself. +;;; o If you modify this software, you must cause the modified +;;; file(s) to carry prominent notices (a Change Log) +;;; describing the changes, who made the changes, and the date +;;; of those changes. +;;; o Any work distributed or published that in whole or in part +;;; contains or is a derivative of this software or any part +;;; thereof is subject to the terms of this agreement. The +;;; aggregation of another unrelated program with this software +;;; or its derivative on a volume of storage or distribution +;;; medium does not bring the other program under the scope +;;; of these terms. +;;; o Permission is granted to manufacturers and distributors of +;;; lisp compilers and interpreters to include this software +;;; with their distribution. +;;; +;;; This software is made available AS IS, and is distributed without +;;; warranty of any kind, either expressed or implied. +;;; +;;; In no event will the author(s) or their institutions be liable to you +;;; for damages, including lost profits, lost monies, or other special, +;;; incidental or consequential damages arising out of or in connection +;;; with the use or inability to use (including but not limited to loss of +;;; data or data being rendered inaccurate or losses sustained by third +;;; parties or a failure of the program to operate as documented) the +;;; program, even if you have been advised of the possibility of such +;;; damanges, or for any claim by any other party, whether in an action of +;;; contract, negligence, or other tortious action. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory +;;; user/ai/lang/lisp/code/tools/xref/ +;;; +;;; Please send bug reports, comments, questions and suggestions to +;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes +;;; or improvements you may make. +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the lisp +;;; utilities collection. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Change Log ********************* +;;; ******************************** +;;; +;;; 27-FEB-91 mk Added insert arg to psgraph-xref to allow the postscript +;;; graphs to be inserted in Scribe documents. +;;; 21-FEB-91 mk Added warning if not compiled. +;;; 07-FEB-91 mk Fixed bug in record-callers with regard to forms at +;;; toplevel. +;;; 21-JAN-91 mk Added file xref-test.lisp to test xref. +;;; 16-JAN-91 mk Added definition WHO-CALLS to parallel the Symbolics syntax. +;;; 16-JAN-91 mk Added macroexpansion capability to record-callers. Also +;;; added parameter *handle-macro-forms*, defaulting to T. +;;; 16-JAN-91 mk Modified print-caller-tree and related functions +;;; to allow the user to specify root nodes. If the user +;;; doesn't specify them, it will default to all root +;;; nodes, as before. +;;; 16-JAN-91 mk Added parameter *default-graphing-mode* to specify +;;; the direction of the graphing. Either :call-graph, +;;; where the children of a node are those functions called +;;; by the node, or :caller-graph where the children of a +;;; node are the callers of the node. :call-graph is the +;;; default. +;;; 16-JAN-91 mk Added parameter *indent-amount* to control the indentation +;;; in print-indented-tree. +;;; 16-JUL-90 mk Functions with argument lists of () were being ignored +;;; because of a (when form) wrapped around the body of +;;; record-callers. Then intent of (when form) was as an extra +;;; safeguard against infinite looping. This wasn't really +;;; necessary, so it has been removed. +;;; 16-JUL-90 mk PSGraph-XREF now has keyword arguments, instead of +;;; optionals. +;;; 16-JUL-90 mk Added PRINT-CLASS-HIERARCHY to use psgraph to graph the +;;; CLOS class hierarchy. This really doesn't belong here, +;;; and should be moved to psgraph.lisp as an example of how +;;; to use psgraph. +;;; 16-JUL-90 mk Fixed several caller patterns. The pattern for member +;;; had an error which caused many references to be missed. +;;; 16-JUL-90 mk Added ability to save/load processed databases. +;;; 5-JUL-91 mk Fixed warning of needing compilation to occur only when the +;;; source is loaded. +;;; 20-SEP-93 mk Added fix from Peter Norvig to allow Xref to xref itself. +;;; The arg to macro-function must be a symbol. +;;; 7-APR-12 heller Break lines at 80 columns. + +;;; ******************************** +;;; To Do ************************** +;;; ******************************** +;;; +;;; Verify that: +;;; o null forms don't cause it to infinite loop. +;;; o nil matches against null argument lists. +;;; o declarations and doc are being ignored. +;;; +;;; Would be nice if in addition to showing callers of a function, it +;;; displayed the context of the calls to the function (e.g., the +;;; immediately surrounding form). This entails storing entries of +;;; the form (symbol context*) in the database and augmenting +;;; record-callers to keep the context around. The only drawbacks is +;;; that it would cons a fair bit. If we do this, we should store +;;; additional information as well in the database, such as the caller +;;; pattern type (e.g., variable vs. function). +;;; +;;; Write a translator from BNF (at least as much of BNF as is used +;;; in CLtL2), to the format used here. +;;; +;;; Should automatically add new patterns for new functions and macros +;;; based on their arglists. Probably requires much more than this +;;; simple code walker, so there isn't much we can do. +;;; +;;; Defmacro is a problem, because it often hides internal function +;;; calls within backquote and quote, which we normally ignore. If +;;; we redefine QUOTE's pattern so that it treats the arg like a FORM, +;;; we'll probably get them (though maybe the syntax will be mangled), +;;; but most likely a lot of spurious things as well. +;;; +;;; Define an operation for Defsystem which will run XREF-FILE on the +;;; files of the system. Or yet simpler, when XREF sees a LOAD form +;;; for which the argument is a string, tries to recursively call +;;; XREF-FILE on the specified file. Then one could just XREF-FILE +;;; the file which loads the system. (This should be a program +;;; parameter.) +;;; +;;; Have special keywords which the user may place in a file to have +;;; XREF-FILE ignore a region. +;;; +;;; Should we distinguish flet and labels from defun? I.e., note that +;;; flet's definitions are locally defined, instead of just lumping +;;; them in with regular definitions. +;;; +;;; Add patterns for series, loop macro. +;;; +;;; Need to integrate the variable reference database with the other +;;; databases, yet maintain separation. So we can distinguish all +;;; the different types of variable and function references, without +;;; multiplying databases. +;;; +;;; Would pay to comment record-callers and record-callers* in more +;;; depth. +;;; +;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT) + +;;; ******************************** +;;; Notes ************************** +;;; ******************************** +;;; +;;; XREF has been tested (successfully) in the following lisps: +;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90) +;;; Macintosh Allegro Common Lisp (1.3.2) +;;; ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90) +;;; Lucid CL (Version 2.1 6-DEC-87) +;;; +;;; XREF has been tested (unsuccessfully) in the following lisps: +;;; Ibuki Common Lisp (01/01, October 15, 1987) +;;; - if interpreted, runs into stack overflow +;;; - does not compile (tried ibcl on Suns, PMAXes and RTs) +;;; seems to be due to a limitation in the c compiler. +;;; +;;; XREF needs to be tested in the following lisps: +;;; Symbolics Common Lisp (8.0) +;;; Lucid Common Lisp (3.0, 4.0) +;;; KCL (June 3, 1987 or later) +;;; AKCL (1.86, June 30, 1987 or later) +;;; TI (Release 4.1 or later) +;;; Golden Common Lisp (3.1 IBM-PC) +;;; VAXLisp (2.0, 3.1) +;;; HP Common Lisp (same as Lucid?) +;;; Procyon Common Lisp + + +;;; **************************************************************** +;;; Documentation ************************************************** +;;; **************************************************************** +;;; +;;; XREF analyzes a user's program, determining which functions call a +;;; given function, and the location of where variables are bound/assigned +;;; and used. The user may retrieve this information for either a single +;;; symbol, or display the call graph of portions of the program +;;; (including the entire program). This allows the programmer to debug +;;; and document the program's structure. +;;; +;;; XREF is primarily intended for analyzing large programs, where it is +;;; difficult, if not impossible, for the programmer to grasp the structure +;;; of the whole program. Nothing precludes using XREF for smaller programs, +;;; where it can be useful for inspecting the relationships between pieces +;;; of the program and for documenting the program. +;;; +;;; Two aspects of the Lisp programming language greatly simplify the +;;; analysis of Lisp programs: +;;; o Lisp programs are naturally represented as data. +;;; Successive definitions from a file are easily read in +;;; as list structure. +;;; o The basic syntax of Lisp is uniform. A list program +;;; consists of a set of nested forms, where each form is +;;; a list whose car is a tag (e.g., function name) that +;;; specifies the structure of the rest of the form. +;;; Thus Lisp programs, when represented as data, can be considered to be +;;; parse trees. Given a grammar of syntax patterns for the language, XREF +;;; recursively descends the parse tree for a given definition, computing +;;; a set of relations that hold for the definition at each node in the +;;; tree. For example, one kind of relation is that the function defined +;;; by the definition calls the functions in its body. The relations are +;;; stored in a database for later examination by the user. +;;; +;;; While XREF currently only works for programs written in Lisp, it could +;;; be extended to other programming languages by writing a function to +;;; generate parse trees for definitions in that language, and a core +;;; set of patterns for the language's syntax. +;;; +;;; Since XREF normally does a static syntactic analysis of the program, +;;; it does not detect references due to the expansion of a macro definition. +;;; To do this in full generality XREF would have to have knowledge about the +;;; semantics of the program (e.g., macros which call other functions to +;;; do the expansion). This entails either modifying the compiler to +;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing +;;; a walk of loaded code and macroexpanding as needed (PCL code walker). +;;; The former is not portable, while the latter requires that the code +;;; used by macros be loaded and in working order. On the other hand, then +;;; we would need no special knowledge about macros (excluding the 24 special +;;; forms of Lisp). +;;; +;;; Parameters may be set to enable macro expansion in XREF. Then XREF +;;; will expand any macros for which it does not have predefined patterns. +;;; (For example, most Lisps will implement dolist as a macro. Since XREF +;;; has a pattern defined for dolist, it will not call macroexpand-1 on +;;; a form whose car is dolist.) For this to work properly, the code must +;;; be loaded before being processed by XREF, and XREF's parameters should +;;; be set so that it processes forms in their proper packages. +;;; +;;; If macro expansion is disabled, the default rules for handling macro +;;; references may not be sufficient for some user-defined macros, because +;;; macros allow a variety of non-standard syntactic extensions to the +;;; language. In this case, the user may specify additional templates in +;;; a manner similar to that in which the core Lisp grammar was specified. +;;; + + +;;; ******************************** +;;; User Guide ********************* +;;; ******************************** +;;; ----- +;;; The following functions are called to cross reference the source files. +;;; +;;; XREF-FILES (&rest files) [FUNCTION] +;;; Grovels over the lisp code located in source file FILES, using +;;; xref-file. +;;; +;;; XREF-FILE (filename &optional clear-tables verbose) [Function] +;;; Cross references the function and variable calls in FILENAME by +;;; walking over the source code located in the file. Defaults type of +;;; filename to ".lisp". Chomps on the code using record-callers and +;;; record-callers*. If CLEAR-TABLES is T (the default), it clears the +;;; callers database before processing the file. Specify CLEAR-TABLES as +;;; nil to append to the database. If VERBOSE is T (the default), prints +;;; out the name of the file, one progress dot for each form processed, +;;; and the total number of forms. +;;; +;;; ----- +;;; The following functions display information about the uses of the +;;; specified symbol as a function, variable, or constant. +;;; +;;; LIST-CALLERS (symbol) [FUNCTION] +;;; Lists all functions which call SYMBOL as a function (function +;;; invocation). +;;; +;;; LIST-READERS (symbol) [FUNCTION] +;;; Lists all functions which refer to SYMBOL as a variable +;;; (variable reference). +;;; +;;; LIST-SETTERS (symbol) [FUNCTION] +;;; Lists all functions which bind/set SYMBOL as a variable +;;; (variable mutation). +;;; +;;; LIST-USERS (symbol) [FUNCTION] +;;; Lists all functions which use SYMBOL as a variable or function. +;;; +;;; WHO-CALLS (symbol &optional how) [FUNCTION] +;;; Lists callers of symbol. HOW may be :function, :reader, :setter, +;;; or :variable." +;;; +;;; WHAT-FILES-CALL (symbol) [FUNCTION] +;;; Lists names of files that contain uses of SYMBOL +;;; as a function, variable, or constant. +;;; +;;; SOURCE-FILE (symbol) [FUNCTION] +;;; Lists the names of files in which SYMBOL is defined/used. +;;; +;;; LIST-CALLEES (symbol) [FUNCTION] +;;; Lists names of functions and variables called by SYMBOL. +;;; +;;; ----- +;;; The following functions may be useful for viewing the database and +;;; debugging the calling patterns. +;;; +;;; *LAST-FORM* () [VARIABLE] +;;; The last form read from the file. Useful for figuring out what went +;;; wrong when xref-file drops into the debugger. +;;; +;;; *XREF-VERBOSE* t [VARIABLE] +;;; When T, xref-file(s) prints out the names of the files it looks at, +;;; progress dots, and the number of forms read. +;;; +;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2)) [VARIABLE] +;;; Default set of caller types (as specified in the patterns) to ignore +;;; in the database handling functions. :lisp is CLtL 1st edition, +;;; :lisp2 is additional patterns from CLtL 2nd edition. +;;; +;;; *HANDLE-PACKAGE-FORMS* () [VARIABLE] +;;; When non-NIL, and XREF-FILE sees a package-setting form like +;;; IN-PACKAGE, sets the current package to the specified package by +;;; evaluating the form. When done with the file, xref-file resets the +;;; package to its original value. In some of the displaying functions, +;;; when this variable is non-NIL one may specify that all symbols from a +;;; particular set of packages be ignored. This is only useful if the +;;; files use different packages with conflicting names. +;;; +;;; *HANDLE-FUNCTION-FORMS* t [VARIABLE] +;;; When T, XREF-FILE tries to be smart about forms which occur in +;;; a function position, such as lambdas and arbitrary Lisp forms. +;;; If so, it recursively calls record-callers with pattern 'FORM. +;;; If the form is a lambda, makes the caller a caller of +;;; :unnamed-lambda. +;;; +;;; *HANDLE-MACRO-FORMS* t [VARIABLE] +;;; When T, if the file was loaded before being processed by XREF, and +;;; the car of a form is a macro, it notes that the parent calls the +;;; macro, and then calls macroexpand-1 on the form. +;;; +;;; *DEFAULT-GRAPHING-MODE* :call-graph [VARIABLE] +;;; Specifies whether we graph up or down. If :call-graph, the children +;;; of a node are the functions it calls. If :caller-graph, the +;;; children of a node are the functions that call it. +;;; +;;; *INDENT-AMOUNT* 3 [VARIABLE] +;;; Number of spaces to indent successive levels in PRINT-INDENTED-TREE. +;;; +;;; DISPLAY-DATABASE (&optional database types-to-ignore) [FUNCTION] +;;; Prints out the name of each symbol and all its callers. Specify +;;; database :callers (the default) to get function call references, +;;; :file to the get files in which the symbol is called, :readers to get +;;; variable references, and :setters to get variable binding and +;;; assignments. Ignores functions of types listed in types-to-ignore. +;;; +;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact root-nodes) +;;; Prints the calling trees (which may actually be a full graph and not +;;; necessarily a DAG) as indented text trees using +;;; PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children +;;; of a node are the functions called by the node, or :caller-graph for +;;; trees where the children of a node are the functions the node calls. +;;; TYPES-TO-IGNORE is a list of funcall types (as specified in the +;;; patterns) to ignore in printing out the database. For example, +;;; '(:lisp) would ignore all calls to common lisp functions. COMPACT is +;;; a flag to tell the program to try to compact the trees a bit by not +;;; printing trees if they have already been seen. ROOT-NODES is a list +;;; of root nodes of trees to display. If ROOT-NODES is nil, tries to +;;; find all root nodes in the database. +;;; +;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*) [FUNCTION] +;;; (types-to-ignore *types-to-ignore*) +;;; compact) +;;; Outputs list structure of a tree which roughly represents the +;;; possibly cyclical structure of the caller database. +;;; If mode is :call-graph, the children of a node are the functions +;;; it calls. If mode is :caller-graph, the children of a node are the +;;; functions that call it. +;;; If compact is T, tries to eliminate the already-seen nodes, so +;;; that the graph for a node is printed at most once. Otherwise it will +;;; duplicate the node's tree (except for cycles). This is usefull +;;; because the call tree is actually a directed graph, so we can either +;;; duplicate references or display only the first one. +;;; +;;; DETERMINE-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Makes a hash table of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically resolving +;;; file references for automatic creation of a system definition +;;; (defsystem). +;;; +;;; PRINT-FILE-DEPENDENCIES (&optional database) [FUNCTION] +;;; Prints a list of file dependencies for the references listed in +;;; DATABASE. This function may be useful for automatically computing +;;; file loading constraints for a system definition tool. +;;; +;;; WRITE-CALLERS-DATABASE-TO-FILE (filename) [FUNCTION] +;;; Saves the contents of the current callers database to a file. This +;;; file can be loaded to restore the previous contents of the +;;; database. (For large systems it can take a long time to crunch +;;; through the code, so this can save some time.) +;;; +;;; ----- +;;; The following macros define new function and macro call patterns. +;;; They may be used to extend the static analysis tool to handle +;;; new def forms, extensions to Common Lisp, and program defs. +;;; +;;; DEFINE-PATTERN-SUBSTITUTION (name pattern) [MACRO] +;;; Defines NAME to be equivalent to the specified pattern. Useful for +;;; making patterns more readable. For example, the LAMBDA-LIST is +;;; defined as a pattern substitution, making the definition of the +;;; DEFUN caller-pattern simpler. +;;; +;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type) [MACRO] +;;; Defines NAME as a function/macro call with argument structure +;;; described by PATTERN. CALLER-TYPE, if specified, assigns a type to +;;; the pattern, which may be used to exclude references to NAME while +;;; viewing the database. For example, all the Common Lisp definitions +;;; have a caller-type of :lisp or :lisp2, so that you can exclude +;;; references to common lisp functions from the calling tree. +;;; +;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type) [MACRO] +;;; Defines NAME as a variable reference of type CALLER-TYPE. This is +;;; mainly used to establish the caller-type of the variable. +;;; +;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations) [MACRO] +;;; For defining function caller pattern syntax synonyms. For each name +;;; in DESTINATIONS, defines its pattern as a copy of the definition +;;; of SOURCE. Allows a large number of identical patterns to be defined +;;; simultaneously. Must occur after the SOURCE has been defined. +;;; +;;; ----- +;;; This system includes pattern definitions for the latest +;;; common lisp specification, as published in Guy Steele, +;;; Common Lisp: The Language, 2nd Edition. +;;; +;;; Patterns may be either structures to match, or a predicate +;;; like symbolp/numberp/stringp. The pattern specification language +;;; is similar to the notation used in CLtL2, but in a more lisp-like +;;; form: +;;; (:eq name) The form element must be eq to the symbol NAME. +;;; (:test test) TEST must be true when applied to the form element. +;;; (:typep type) The form element must be of type TYPE. +;;; (:or pat1 pat2 ...) Tries each of the patterns in left-to-right order, +;;; until one succeeds. +;;; Equivalent to { pat1 | pat2 | ... } +;;; (:rest pattern) The remaining form elements are grouped into a +;;; list which is matched against PATTERN. +;;; (:optional pat1 ...) The patterns may optionally match against the +;;; form element. +;;; Equivalent to [ pat1 ... ]. +;;; (:star pat1 ...) The patterns may match against the patterns +;;; any number of times, including 0. +;;; Equivalent to { pat1 ... }*. +;;; (:plus pat1 ...) The patterns may match against the patterns +;;; any number of times, but at least once. +;;; Equivalent to { pat1 ... }+. +;;; &optional, &key, Similar in behavior to the corresponding +;;; &rest lambda-list keywords. +;;; FORM A random lisp form. If a cons, assumes the +;;; car is a function or macro and tries to +;;; match the args against that symbol's pattern. +;;; If a symbol, assumes it's a variable reference. +;;; :ignore Ignores the corresponding form element. +;;; NAME The corresponding form element should be +;;; the name of a new definition (e.g., the +;;; first arg in a defun pattern is NAME. +;;; FUNCTION, MACRO The corresponding form element should be +;;; a function reference not handled by FORM. +;;; Used in the definition of apply and funcall. +;;; VAR The corresponding form element should be +;;; a variable definition or mutation. Used +;;; in the definition of let, let*, etc. +;;; VARIABLE The corresponding form element should be +;;; a variable reference. +;;; +;;; In all other pattern symbols, it looks up the symbols pattern substitution +;;; and recursively matches against the pattern. Automatically destructures +;;; list structure that does not include consing dots. +;;; +;;; Among the pattern substitution names defined are: +;;; STRING, SYMBOL, NUMBER Appropriate :test patterns. +;;; LAMBDA-LIST Matches against a lambda list. +;;; BODY Matches against a function body definition. +;;; FN Matches against #'function, 'function, +;;; and lambdas. This is used in the definition +;;; of apply, funcall, and the mapping patterns. +;;; and others... +;;; +;;; Here's some sample pattern definitions: +;;; (define-caller-pattern defun +;;; (name lambda-list +;;; (:star (:or documentation-string declaration)) +;;; (:star form)) +;;; :lisp) +;;; (define-caller-pattern funcall (fn (:star form)) :lisp) +;;; +;;; In general, the system is intelligent enough to handle any sort of +;;; simple funcall. One only need specify the syntax for functions and +;;; macros which use optional arguments, keyword arguments, or some +;;; argument positions are special, such as in apply and funcall, or +;;; to indicate that the function is of the specified caller type. +;;; +;;; +;;; NOTES: +;;; +;;; XRef assumes syntactically correct lisp code. +;;; +;;; This is by no means perfect. For example, let and let* are treated +;;; identically, instead of differentiating between serial and parallel +;;; binding. But it's still a useful tool. It can be helpful in +;;; maintaining code, debugging problems with patch files, determining +;;; whether functions are multiply defined, and help you remember where +;;; a function is defined or called. +;;; +;;; XREF runs best when compiled. + +;;; ******************************** +;;; References ********************* +;;; ******************************** +;;; +;;; Xerox Interlisp Masterscope Program: +;;; Larry M Masinter, Global program analysis in an interactive environment +;;; PhD Thesis, Stanford University, 1980. +;;; +;;; Symbolics Who-Calls Database: +;;; User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986 +;;; Genera 7.0, pp 183-185. +;;; + +;;; ******************************** +;;; Example ************************ +;;; ******************************** +;;; +;;; Here is an example of running XREF on a short program. +;;; [In Scribe documentation, give a simple short program and resulting +;;; XREF output, including postscript call graphs.] +#| + (xref:xref-file "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp") +Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp. +................................................ +48 forms processed. + (xref:display-database :readers) + +*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO. +*DIRECTION* is referenced by CREATE-POSITION-INFO. +*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT. +*ROOT-IS-SEQUENCE* is referenced by GRAPH. +*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE. +*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL. +*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO. +*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE. +*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION +CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE. +*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE. + (xref:print-caller-trees :root-nodes '(display-graph)) + +Rooted calling trees: + DISPLAY-GRAPH + CREATE-POSITION-INFO + CALCULATE-POSITION-INFO + CALCULATE-POSITION + NODE-POSITION-ALREADY-SET-FLAG + NODE-LEVEL-ALREADY-SET-FLAG + CALCULATE-POSITION-IN-LEVEL + NODE-CHILDREN + NODE-LEVEL + CALCULATE-POSITION + NEW-CALCULATE-BREADTH + NODE-CHILDREN + BREADTH + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + NEW-CALCULATE-BREADTH + NODE-PARENTS + OPPOSITE-DIMENSION + NODE-HEIGHT + NODE-WIDTH + OPPOSITE-POSITION + NODE-Y + NODE-X + NODE-LEVEL + CALCULATE-LEVEL-POSITION + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + DIMENSION + NODE-WIDTH + NODE-HEIGHT + CALCULATE-LEVEL-POSITION-BEFORE + NODE-LEVEL + NODE-POSITION + NODE-X + NODE-Y + NODE-WIDTH + NODE-HEIGHT + DIMENSION + NODE-WIDTH + NODE-HEIGHT +|# + +;;; **************************************************************** +;;; List Callers *************************************************** +;;; **************************************************************** + +(defpackage :pxref + (:use :common-lisp) + (:export #:list-callers + #:list-users + #:list-readers + #:list-setters + #:what-files-call + #:who-calls + #:list-callees + #:source-file + #:clear-tables + #:define-pattern-substitution + #:define-caller-pattern + #:define-variable-pattern + #:define-caller-pattern-synonyms + #:clear-patterns + #:*last-form* + #:*xref-verbose* + #:*handle-package-forms* + #:*handle-function-forms* + #:*handle-macro-forms* + #:*types-to-ignore* + #:*last-caller-tree* + #:*default-graphing-mode* + #:*indent-amount* + #:xref-file + #:xref-files + #:write-callers-database-to-file + #:display-database + #:print-caller-trees + #:make-caller-tree + #:print-indented-tree + #:determine-file-dependencies + #:print-file-dependencies + #:psgraph-xref + )) + +(in-package "PXREF") + +;;; Warn user if they're loading the source instead of compiling it first. +;(eval-when (compile load eval) +; (defvar compiled-p nil)) +;(eval-when (compile load) +; (setq compiled-p t)) +;(eval-when (load eval) +; (unless compiled-p +; (warn "This file should be compiled before loading for best results."))) +(eval-when (eval) + (warn "This file should be compiled before loading for best results.")) + + +;;; ******************************** +;;; Primitives ********************* +;;; ******************************** +(defun lookup (symbol environment) + (dolist (frame environment) + (when (member symbol frame) + (return symbol)))) + +(defun car-eq (list item) + (and (consp list) + (eq (car list) item))) + +;;; ******************************** +;;; Callers Database *************** +;;; ******************************** +(defvar *file-callers-database* (make-hash-table :test #'equal) + "Contains name and list of file callers (files which call) for that name.") +(defvar *callers-database* (make-hash-table :test #'equal) + "Contains name and list of callers (function invocation) for that name.") +(defvar *readers-database* (make-hash-table :test #'equal) + "Contains name and list of readers (variable use) for that name.") +(defvar *setters-database* (make-hash-table :test #'equal) + "Contains name and list of setters (variable mutation) for that name.") +(defvar *callees-database* (make-hash-table :test #'equal) + "Contains name and list of functions and variables it calls.") +(defun callers-list (name &optional (database :callers)) + (case database + (:file (gethash name *file-callers-database*)) + (:callees (gethash name *callees-database*)) + (:callers (gethash name *callers-database*)) + (:readers (gethash name *readers-database*)) + (:setters (gethash name *setters-database*)))) +(defsetf callers-list (name &optional (database :callers)) (caller) + `(setf (gethash ,name (case ,database + (:file *file-callers-database*) + (:callees *callees-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*))) + ,caller)) + +(defun list-callers (symbol) + "Lists all functions which call SYMBOL as a function (function invocation)." + (callers-list symbol :callers)) +(defun list-readers (symbol) + "Lists all functions which refer to SYMBOL as a variable + (variable reference)." + (callers-list symbol :readers)) +(defun list-setters (symbol) + "Lists all functions which bind/set SYMBOL as a variable + (variable mutation)." + (callers-list symbol :setters)) +(defun list-users (symbol) + "Lists all functions which use SYMBOL as a variable or function." + (values (list-callers symbol) + (list-readers symbol) + (list-setters symbol))) +(defun who-calls (symbol &optional how) + "Lists callers of symbol. HOW may be :function, :reader, :setter, + or :variable." + ;; would be nice to have :macro and distinguish variable + ;; binding from assignment. (i.e., variable binding, assignment, and use) + (case how + (:function (list-callers symbol)) + (:reader (list-readers symbol)) + (:setter (list-setters symbol)) + (:variable (append (list-readers symbol) + (list-setters symbol))) + (otherwise (append (list-callers symbol) + (list-readers symbol) + (list-setters symbol))))) +(defun what-files-call (symbol) + "Lists names of files that contain uses of SYMBOL + as a function, variable, or constant." + (callers-list symbol :file)) +(defun list-callees (symbol) + "Lists names of functions and variables called by SYMBOL." + (callers-list symbol :callees)) + +(defvar *source-file* (make-hash-table :test #'equal) + "Contains function name and source file for that name.") +(defun source-file (symbol) + "Lists the names of files in which SYMBOL is defined/used." + (gethash symbol *source-file*)) +(defsetf source-file (name) (value) + `(setf (gethash ,name *source-file*) ,value)) + +(defun clear-tables () + (clrhash *file-callers-database*) + (clrhash *callers-database*) + (clrhash *callees-database*) + (clrhash *readers-database*) + (clrhash *setters-database*) + (clrhash *source-file*)) + + +;;; ******************************** +;;; Pattern Database *************** +;;; ******************************** +;;; Pattern Types +(defvar *pattern-caller-type* (make-hash-table :test #'equal)) +(defun pattern-caller-type (name) + (gethash name *pattern-caller-type*)) +(defsetf pattern-caller-type (name) (value) + `(setf (gethash ,name *pattern-caller-type*) ,value)) + +;;; Pattern Substitutions +(defvar *pattern-substitution-table* (make-hash-table :test #'equal) + "Stores general patterns for function destructuring.") +(defun lookup-pattern-substitution (name) + (gethash name *pattern-substitution-table*)) +(defmacro define-pattern-substitution (name pattern) + "Defines NAME to be equivalent to the specified pattern. Useful for + making patterns more readable. For example, the LAMBDA-LIST is + defined as a pattern substitution, making the definition of the + DEFUN caller-pattern simpler." + `(setf (gethash ',name *pattern-substitution-table*) + ',pattern)) + +;;; Function/Macro caller patterns: +;;; The car of the form is skipped, so we don't need to specify +;;; (:eq function-name) like we would for a substitution. +;;; +;;; Patterns must be defined in the XREF package because the pattern +;;; language is tested by comparing symbols (using #'equal) and not +;;; their printreps. This is fine for the lisp grammer, because the XREF +;;; package depends on the LISP package, so a symbol like 'xref::cons is +;;; translated automatically into 'lisp::cons. However, since +;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and +;;; 'baz::bar are inherited from the same package (e.g., LISP), +;;; if package handling is turned on the user must specify package +;;; names in the caller pattern definitions for functions that occur +;;; in packages other than LISP, otherwise the symbols will not match. +;;; +;;; Perhaps we should enforce the definition of caller patterns in the +;;; XREF package by wrapping the body of define-caller-pattern in +;;; the XREF package: +;;; (defmacro define-caller-pattern (name value &optional caller-type) +;;; (let ((old-package *package*)) +;;; (setf *package* (find-package "XREF")) +;;; (prog1 +;;; `(progn +;;; (when ',caller-type +;;; (setf (pattern-caller-type ',name) ',caller-type)) +;;; (when ',value +;;; (setf (gethash ',name *caller-pattern-table*) +;;; ',value))) +;;; (setf *package* old-package)))) +;;; Either that, or for the purpose of pattern testing we should compare +;;; printreps. [The latter makes the primitive patterns like VAR +;;; reserved words.] +(defvar *caller-pattern-table* (make-hash-table :test #'equal) + "Stores patterns for function destructuring.") +(defun lookup-caller-pattern (name) + (gethash name *caller-pattern-table*)) +(defmacro define-caller-pattern (name pattern &optional caller-type) + "Defines NAME as a function/macro call with argument structure + described by PATTERN. CALLER-TYPE, if specified, assigns a type to + the pattern, which may be used to exclude references to NAME while + viewing the database. For example, all the Common Lisp definitions + have a caller-type of :lisp or :lisp2, so that you can exclude + references to common lisp functions from the calling tree." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)) + (when ',pattern + (setf (gethash ',name *caller-pattern-table*) + ',pattern)))) + +;;; For defining variables +(defmacro define-variable-pattern (name &optional caller-type) + "Defines NAME as a variable reference of type CALLER-TYPE. This is + mainly used to establish the caller-type of the variable." + `(progn + (when ',caller-type + (setf (pattern-caller-type ',name) ',caller-type)))) + +;;; For defining synonyms. Means much less space taken up by the patterns. +(defmacro define-caller-pattern-synonyms (source destinations) + "For defining function caller pattern syntax synonyms. For each name + in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE. + Allows a large number of identical patterns to be defined simultaneously. + Must occur after the SOURCE has been defined." + `(let ((source-type (pattern-caller-type ',source)) + (source-pattern (gethash ',source *caller-pattern-table*))) + (when source-type + (dolist (dest ',destinations) + (setf (pattern-caller-type dest) source-type))) + (when source-pattern + (dolist (dest ',destinations) + (setf (gethash dest *caller-pattern-table*) + source-pattern))))) + +(defun clear-patterns () + (clrhash *pattern-substitution-table*) + (clrhash *caller-pattern-table*) + (clrhash *pattern-caller-type*)) + +;;; ******************************** +;;; Cross Reference Files ********** +;;; ******************************** +(defvar *last-form* () + "The last form read from the file. Useful for figuring out what went wrong + when xref-file drops into the debugger.") + +(defvar *xref-verbose* t + "When T, xref-file(s) prints out the names of the files it looks at, + progress dots, and the number of forms read.") + +;;; This needs to first clear the tables? +(defun xref-files (&rest files) + "Grovels over the lisp code located in source file FILES, using xref-file." + ;; If the arg is a list, use it. + (when (listp (car files)) (setq files (car files))) + (dolist (file files) + (xref-file file nil)) + (values)) + +(defvar *handle-package-forms* nil ;'(lisp::in-package) + "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE, + sets the current package to the specified package by evaluating the + form. When done with the file, xref-file resets the package to its + original value. In some of the displaying functions, when this variable + is non-NIL one may specify that all symbols from a particular set of + packages be ignored. This is only useful if the files use different + packages with conflicting names.") + +(defvar *normal-readtable* (copy-readtable nil) + "Normal, unadulterated CL readtable.") + +(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*)) + "Cross references the function and variable calls in FILENAME by + walking over the source code located in the file. Defaults type of + filename to \".lisp\". Chomps on the code using record-callers and + record-callers*. If CLEAR-TABLES is T (the default), it clears the callers + database before processing the file. Specify CLEAR-TABLES as nil to + append to the database. If VERBOSE is T (the default), prints out the + name of the file, one progress dot for each form processed, and the + total number of forms." + ;; Default type to "lisp" + (when (and (null (pathname-type filename)) + (not (probe-file filename))) + (cond ((stringp filename) + (setf filename (concatenate 'string filename ".lisp"))) + ((pathnamep filename) + (setf filename (merge-pathnames filename + (make-pathname :type "lisp")))))) + (when clear-tables (clear-tables)) + (let ((count 0) + (old-package *package*) + (*readtable* *normal-readtable*)) + (when verbose + (format t "~&Cross-referencing file ~A.~&" filename)) + (with-open-file (stream filename :direction :input) + (do ((form (read stream nil :eof) (read stream nil :eof))) + ((eq form :eof)) + (incf count) + (when verbose + (format *standard-output* ".") + (force-output *standard-output*)) + (setq *last-form* form) + (record-callers filename form) + ;; Package Magic. + (when (and *handle-package-forms* + (consp form) + (member (car form) *handle-package-forms*)) + (eval form)))) + (when verbose + (format t "~&~D forms processed." count)) + (setq *package* old-package) + (values))) + +(defvar *handle-function-forms* t + "When T, XREF-FILE tries to be smart about forms which occur in + a function position, such as lambdas and arbitrary Lisp forms. + If so, it recursively calls record-callers with pattern 'FORM. + If the form is a lambda, makes the caller a caller of :unnamed-lambda.") + +(defvar *handle-macro-forms* t + "When T, if the file was loaded before being processed by XREF, and the + car of a form is a macro, it notes that the parent calls the macro, + and then calls macroexpand-1 on the form.") + +(defvar *callees-database-includes-variables* nil) + +(defun record-callers (filename form + &optional pattern parent (environment nil) + funcall) + "RECORD-CALLERS is the main routine used to walk down the code. It matches + the PATTERN against the FORM, possibly adding statements to the database. + PARENT is the name defined by the current outermost definition; it is + the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used + to keep track of the scoping of variables. FUNCALL deals with the type + of variable assignment and hence how the environment should be modified. + RECORD-CALLERS handles atomic patterns and simple list-structure patterns. + For complex list-structure pattern destructuring, it calls RECORD-CALLERS*." +; (when form) + (unless pattern (setq pattern 'FORM)) + (cond ((symbolp pattern) + (case pattern + (:IGNORE + ;; Ignores the rest of the form. + (values t parent environment)) + (NAME + ;; This is the name of a new definition. + (push filename (source-file form)) + (values t form environment)) + ((FUNCTION MACRO) + ;; This is the name of a call. + (cond ((and *handle-function-forms* (consp form)) + ;; If we're a cons and special handling is on, + (when (eq (car form) 'lambda) + (pushnew filename (callers-list :unnamed-lambda :file)) + (when parent + (pushnew parent (callers-list :unnamed-lambda + :callers)) + (pushnew :unnamed-lambda (callers-list parent + :callees)))) + (record-callers filename form 'form parent environment)) + (t + ;; If we're just a regular function name call. + (pushnew filename (callers-list form :file)) + (when parent + (pushnew parent (callers-list form :callers)) + (pushnew form (callers-list parent :callees))) + (values t parent environment)))) + (VAR + ;; This is the name of a new variable definition. + ;; Includes arglist parameters. + (when (and (symbolp form) (not (keywordp form)) + (not (member form lambda-list-keywords))) + (pushnew form (car environment)) + (pushnew filename (callers-list form :file)) + (when parent +; (pushnew form (callers-list parent :callees)) + (pushnew parent (callers-list form :setters))) + (values t parent environment))) + (VARIABLE + ;; VAR reference + (pushnew filename (callers-list form :file)) + (when (and parent (not (lookup form environment))) + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees)))) + (values t parent environment)) + (FORM + ;; A random form (var or funcall). + (cond ((consp form) + ;; Get new pattern from TAG. + (let ((new-pattern (lookup-caller-pattern (car form)))) + (pushnew filename (callers-list (car form) :file)) + (when parent + (pushnew parent (callers-list (car form) :callers)) + (pushnew (car form) (callers-list parent :callees))) + (cond ((and new-pattern (cdr form)) + ;; Special Pattern and there's stuff left + ;; to be processed. Note that we check if + ;; a pattern is defined for the form before + ;; we check to see if we can macroexpand it. + (record-callers filename (cdr form) new-pattern + parent environment :funcall)) + ((and *handle-macro-forms* + (symbolp (car form)) ; pnorvig 9/9/93 + (macro-function (car form))) + ;; The car of the form is a macro and + ;; macro processing is turned on. Macroexpand-1 + ;; the form and try again. + (record-callers filename + (macroexpand-1 form) + 'form parent environment + :funcall)) + ((null (cdr form)) + ;; No more left to be processed. Note that + ;; this must occur after the macros clause, + ;; since macros can expand into more code. + (values t parent environment)) + (t + ;; Random Form. We assume it is a function call. + (record-callers filename (cdr form) + '((:star FORM)) + parent environment :funcall))))) + (t + (when (and (not (lookup form environment)) + (not (numberp form)) + ;; the following line should probably be + ;; commented out? + (not (keywordp form)) + (not (stringp form)) + (not (eq form t)) + (not (eq form nil))) + (pushnew filename (callers-list form :file)) + ;; ??? :callers + (when parent + (pushnew parent (callers-list form :readers)) + (when *callees-database-includes-variables* + (pushnew form (callers-list parent :callees))))) + (values t parent environment)))) + (otherwise + ;; Pattern Substitution + (let ((new-pattern (lookup-pattern-substitution pattern))) + (if new-pattern + (record-callers filename form new-pattern + parent environment) + (when (eq pattern form) + (values t parent environment))))))) + ((consp pattern) + (case (car pattern) + (:eq (when (eq (second pattern) form) + (values t parent environment))) + (:test (when (funcall (eval (second pattern)) form) + (values t parent environment))) + (:typep (when (typep form (second pattern)) + (values t parent environment))) + (:or (dolist (subpat (rest pattern)) + (multiple-value-bind (processed parent environment) + (record-callers filename form subpat + parent environment) + (when processed + (return (values processed parent environment)))))) + (:rest ; (:star :plus :optional :rest) + (record-callers filename form (second pattern) + parent environment)) + (otherwise + (multiple-value-bind (d p env) + (record-callers* filename form pattern + parent (cons nil environment)) + (values d p (if funcall environment env)))))))) + +(defun record-callers* (filename form pattern parent environment + &optional continuation + in-optionals in-keywords) + "RECORD-CALLERS* handles complex list-structure patterns, such as + ordered lists of subpatterns, patterns involving :star, :plus, + &optional, &key, &rest, and so on. CONTINUATION is a stack of + unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding + stacks which determine whether &rest or &key has been seen yet in + the current pattern." + ;; form must be a cons or nil. +; (when form) + (if (null pattern) + (if (null continuation) + (values t parent environment) + (record-callers* filename form (car continuation) parent environment + (cdr continuation) + (cdr in-optionals) + (cdr in-keywords))) + (let ((pattern-elt (car pattern))) + (cond ((car-eq pattern-elt :optional) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cdr pattern) continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :star) + (if (null form) + (values t parent environment) + (multiple-value-bind (processed par env) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons pattern continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords)) + (if processed + (values processed par env) + (record-callers* filename form (cdr pattern) + parent environment continuation + in-optionals in-keywords))))) + ((car-eq pattern-elt :plus) + (record-callers* filename form (cdr pattern-elt) + parent environment + (cons (cons (cons :star (cdr pattern-elt)) + (cdr pattern)) + continuation) + (cons (car in-optionals) in-optionals) + (cons (car in-keywords) in-keywords))) + ((car-eq pattern-elt :rest) + (record-callers filename form pattern-elt parent environment)) + ((eq pattern-elt '&optional) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons t in-optionals) + (cons (car in-keywords) in-keywords))) + ((eq pattern-elt '&rest) + (record-callers filename form (second pattern) + parent environment)) + ((eq pattern-elt '&key) + (record-callers* filename form (cdr pattern) + parent environment continuation + (cons (car in-optionals) in-optionals) + (cons t in-keywords))) + ((null form) + (when (or (car in-keywords) (car in-optionals)) + (values t parent environment))) + ((consp form) + (multiple-value-bind (processed parent environment) + (record-callers filename (if (car in-keywords) + (cadr form) + (car form)) + pattern-elt + parent environment) + (cond (processed + (record-callers* filename (if (car in-keywords) + (cddr form) + (cdr form)) + (cdr pattern) + parent environment + continuation + in-optionals in-keywords)) + ((or (car in-keywords) + (car in-optionals)) + (values t parent environment))))))))) + + +;;; ******************************** +;;; Misc Utilities ***************** +;;; ******************************** +(defvar *types-to-ignore* + '(:lisp ; CLtL 1st Edition + :lisp2 ; CLtL 2nd Edition additional patterns + ) + "Default set of caller types (as specified in the patterns) to ignore + in the database handling functions. :lisp is CLtL 1st edition, + :lisp2 is additional patterns from CLtL 2nd edition.") + +(defun display-database (&optional (database :callers) + (types-to-ignore *types-to-ignore*)) + "Prints out the name of each symbol and all its callers. Specify database + :callers (the default) to get function call references, :fill to the get + files in which the symbol is called, :readers to get variable references, + and :setters to get variable binding and assignments. Ignores functions + of types listed in types-to-ignore." + (maphash #'(lambda (name callers) + (unless (or (member (pattern-caller-type name) + types-to-ignore) + ;; When we're doing fancy package crap, + ;; allow us to ignore symbols based on their + ;; packages. + (when *handle-package-forms* + (member (symbol-package name) + types-to-ignore + :key #'find-package))) + (format t "~&~S is referenced by~{ ~S~}." + name callers))) + (ecase database + (:file *file-callers-database*) + (:callers *callers-database*) + (:readers *readers-database*) + (:setters *setters-database*)))) + +(defun write-callers-database-to-file (filename) + "Saves the contents of the current callers database to a file. This + file can be loaded to restore the previous contents of the + database. (For large systems it can take a long time to crunch + through the code, so this can save some time.)" + (with-open-file (stream filename :direction :output) + (format stream "~&(clear-tables)") + (maphash #'(lambda (x y) + (format stream "~&(setf (source-file '~S) '~S)" + x y)) + *source-file*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :file) '~S)" + x y)) + *file-callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callers) '~S)" + x y)) + *callers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :callees) '~S)" + x y)) + *callees-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :readers) '~S)" + x y)) + *readers-database*) + (maphash #'(lambda (x y) + (format stream "~&(setf (callers-list '~S :setters) '~S)" + x y)) + *setters-database*))) + + +;;; ******************************** +;;; Print Caller Trees ************* +;;; ******************************** +;;; The following function is useful for reversing a caller table into +;;; a callee table. Possibly later we'll extend xref to create two +;;; such database hash tables. Needs to include vars as well. +(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*)) + "Makes a copy of the hash table in which (name value*) pairs + are inverted to (value name*) pairs." + (let ((target (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (dolist (value values) + (unless (member (pattern-caller-type key) + types-to-ignore) + (pushnew key (gethash value target))))) + table) + target)) + +;;; Resolve file references for automatic creation of a defsystem file. +(defun determine-file-dependencies (&optional (database *callers-database*)) + "Makes a hash table of file dependencies for the references listed in + DATABASE. This function may be useful for automatically resolving + file references for automatic creation of a system definition (defsystem)." + (let ((file-ref-ht (make-hash-table :test #'equal))) + (maphash #'(lambda (key values) + (let ((key-file (source-file key))) + (when key + (dolist (value values) + (let ((value-file (source-file value))) + (when value-file + (dolist (s key-file) + (dolist (d value-file) + (pushnew d (gethash s file-ref-ht)))))))))) + database) + file-ref-ht)) + +(defun print-file-dependencies (&optional (database *callers-database*)) + "Prints a list of file dependencies for the references listed in DATABASE. + This function may be useful for automatically computing file loading + constraints for a system definition tool." + (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value)) + (determine-file-dependencies database))) + +;;; The following functions demonstrate a possible way to interface +;;; xref to a graphical browser such as psgraph to mimic the capabilities +;;; of Masterscope's graphical browser. + +(defvar *last-caller-tree* nil) + +(defvar *default-graphing-mode* :call-graph + "Specifies whether we graph up or down. If :call-graph, the children + of a node are the functions it calls. If :caller-graph, the children + of a node are the functions that call it.") + +(defun gather-tree (parents &optional already-seen + (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Extends the tree, copying it into list structure, until it repeats + a reference (hits a cycle)." + (let ((*already-seen* nil) + (database (case mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (declare (special *already-seen*)) + (labels + ((amass-tree + (parents &optional already-seen) + (let (result this-item) + (dolist (parent parents) + (unless (member (pattern-caller-type parent) + types-to-ignore) + (pushnew parent *already-seen*) + (if (member parent already-seen) + (setq this-item nil) ; :ignore + (if compact + (multiple-value-setq (this-item already-seen) + (amass-tree (gethash parent database) + (cons parent already-seen))) + (setq this-item + (amass-tree (gethash parent database) + (cons parent already-seen))))) + (setq parent (format nil "~S" parent)) + (when (consp parent) (setq parent (cons :xref-list parent))) + (unless (eq this-item :ignore) + (push (if this-item + (list parent this-item) + parent) + result)))) + (values result ;(reverse result) + already-seen)))) + (values (amass-tree parents already-seen) + *already-seen*)))) + +(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*)) + "Returns a list of uncalled callers (roots) and called callers (potential + cycles)." + (let ((uncalled-callers nil) + (called-callers nil) + (database (ecase mode + (:call-graph *callers-database*) + (:caller-graph *callees-database*))) + (other-database (ecase mode + (:call-graph *callees-database*) + (:caller-graph *callers-database*)))) + (maphash #'(lambda (name value) + (declare (ignore value)) + (unless (member (pattern-caller-type name) + types-to-ignore) + (if (gethash name database) + (push name called-callers) + (push name uncalled-callers)))) + other-database) + (values uncalled-callers called-callers))) + +(defun make-caller-tree (&optional (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) compact) + "Outputs list structure of a tree which roughly represents the possibly + cyclical structure of the caller database. + If mode is :call-graph, the children of a node are the functions it calls. + If mode is :caller-graph, the children of a node are the functions that + call it. + If compact is T, tries to eliminate the already-seen nodes, so that + the graph for a node is printed at most once. Otherwise it will duplicate + the node's tree (except for cycles). This is usefull because the call tree + is actually a directed graph, so we can either duplicate references or + display only the first one." + ;; Would be nice to print out line numbers and whenever we skip a duplicated + ;; reference, print the line number of the full reference after the node. + (multiple-value-bind (uncalled-callers called-callers) + (find-roots-and-cycles mode types-to-ignore) + (multiple-value-bind (trees already-seen) + (gather-tree uncalled-callers nil mode types-to-ignore compact) + (setq *last-caller-tree* trees) + (let ((more-trees (gather-tree (set-difference called-callers + already-seen) + already-seen + mode types-to-ignore compact))) + (values trees more-trees))))) + +(defvar *indent-amount* 3 + "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.") + +(defun print-indented-tree (trees &optional (indent 0)) + "Simple code to print out a list-structure tree (such as those created + by make-caller-tree) as indented text." + (when trees + (dolist (tree trees) + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (format t "~&~VT~A" indent (cdr tree))) + ((listp tree) + (format t "~&~VT~A" indent (car tree)) + (print-indented-tree (cadr tree) (+ indent *indent-amount*))) + (t + (format t "~&~VT~A" indent tree)))))) + +(defun print-caller-trees (&key (mode *default-graphing-mode*) + (types-to-ignore *types-to-ignore*) + compact + root-nodes) + "Prints the calling trees (which may actually be a full graph and not + necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE. + MODE is :call-graph for trees where the children of a node are the + functions called by the node, or :caller-graph for trees where the + children of a node are the functions the node calls. TYPES-TO-IGNORE + is a list of funcall types (as specified in the patterns) to ignore + in printing out the database. For example, '(:lisp) would ignore all + calls to common lisp functions. COMPACT is a flag to tell the program + to try to compact the trees a bit by not printing trees if they have + already been seen. ROOT-NODES is a list of root nodes of trees to + display. If ROOT-NODES is nil, tries to find all root nodes in the + database." + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (when rooted + (format t "~&Rooted calling trees:") + (print-indented-tree rooted 2)) + (when cycles + (when rooted + (format t "~2%")) + (format t "~&Cyclic calling trees:") + (print-indented-tree cycles 2)))) + + +;;; ******************************** +;;; Interface to PSGraph *********** +;;; ******************************** +#| +;;; Interface to Bates' PostScript Graphing Utility +(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph") + +(defparameter *postscript-output-directory* "") +(defun psgraph-xref (&key (mode *default-graphing-mode*) + (output-directory *postscript-output-directory*) + (types-to-ignore *types-to-ignore*) + (compact t) + (shrink t) + root-nodes + insert) + ;; If root-nodes is a non-nil list, uses that list as the starting + ;; position. Otherwise tries to find all roots in the database. + (multiple-value-bind (rooted cycles) + (if root-nodes + (values (gather-tree root-nodes nil mode types-to-ignore compact)) + (make-caller-tree mode types-to-ignore compact)) + (psgraph-output (append rooted cycles) output-directory shrink insert))) + +(defun psgraph-output (list-of-trees directory shrink &optional insert) + (let ((psgraph:*fontsize* 9) + (psgraph:*second-fontsize* 7) +; (psgraph:*boxkind* "fill") + (psgraph:*boxgray* "0") ; .8 + (psgraph:*edgewidth* "1") + (psgraph:*edgegray* "0")) + (labels ((stringify (thing) + (cond ((stringp thing) (string-downcase thing)) + ((symbolp thing) (string-downcase (symbol-name thing))) + ((and (listp thing) (eq (car thing) :xref-list)) + (stringify (cdr thing))) + ((listp thing) (stringify (car thing))) + (t (string thing))))) + (dolist (item list-of-trees) + (let* ((fname (stringify item)) + (filename (concatenate 'string directory + (string-trim '(#\: #\|) fname) + ".ps"))) + (format t "~&Creating PostScript file ~S." filename) + (with-open-file (*standard-output* filename + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + ;; Note that the #'eq prints the DAG as a tree. If + ;; you replace it with #'equal, it will print it as + ;; a DAG, which I think is slightly ugly. + (psgraph:psgraph item + #'caller-tree-children #'caller-info shrink + insert #'eq))))))) + +(defun caller-tree-children (tree) + (when (and tree (listp tree) (not (eq (car tree) :xref-list))) + (cadr tree))) + +(defun caller-tree-node (tree) + (when tree + (cond ((and (listp tree) (eq (car tree) :xref-list)) + (cdr tree)) + ((listp tree) + (car tree)) + (t + tree)))) + +(defun caller-info (tree) + (let ((node (caller-tree-node tree))) + (list node))) +|# +#| +;;; Code to print out graphical trees of CLOS class hierarchies. +(defun print-class-hierarchy (&optional (start-class 'anything) + (file "classes.ps")) + (let ((start (find-class start-class))) + (when start + (with-open-file (*standard-output* file :direction :output) + (psgraph:psgraph start + #'clos::class-direct-subclasses + #'(lambda (x) + (list (format nil "~A" (clos::class-name x)))) + t nil #'eq))))) + +|# + + +;;; **************************************************************** +;;; Cross Referencing Patterns for Common Lisp ********************* +;;; **************************************************************** +(clear-patterns) + +;;; ******************************** +;;; Pattern Substitutions ********** +;;; ******************************** +(define-pattern-substitution integer (:test #'integerp)) +(define-pattern-substitution rational (:test #'rationalp)) +(define-pattern-substitution symbol (:test #'symbolp)) +(define-pattern-substitution string (:test #'stringp)) +(define-pattern-substitution number (:test #'numberp)) +(define-pattern-substitution lambda-list + ((:star var) + (:optional (:eq &optional) + (:star (:or var + (var (:optional form (:optional var)))))) + (:optional (:eq &rest) var) + (:optional (:eq &key) (:star (:or var + ((:or var + (keyword var)) + (:optional form (:optional var))))) + (:optional &allow-other-keys)) + (:optional (:eq &aux) + (:star (:or var + (var (:optional form))))))) +(define-pattern-substitution test form) +(define-pattern-substitution body + ((:star (:or declaration documentation-string)) + (:star form))) +(define-pattern-substitution documentation-string string) +(define-pattern-substitution initial-value form) +(define-pattern-substitution tag symbol) +(define-pattern-substitution declaration ((:eq declare)(:rest :ignore))) +(define-pattern-substitution destination form) +(define-pattern-substitution control-string string) +(define-pattern-substitution format-arguments + ((:star form))) +(define-pattern-substitution fn + (:or ((:eq quote) function) + ((:eq function) function) + function)) + +;;; ******************************** +;;; Caller Patterns **************** +;;; ******************************** + +;;; Types Related +(define-caller-pattern coerce (form :ignore) :lisp) +(define-caller-pattern type-of (form) :lisp) +(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2) +(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2) + +;;; Lambdas and Definitions +(define-variable-pattern lambda-list-keywords :lisp) +(define-variable-pattern lambda-parameters-limit :lisp) +(define-caller-pattern lambda (lambda-list (:rest body)) :lisp) + +(define-caller-pattern defun + (name lambda-list + (:star (:or documentation-string declaration)) + (:star form)) + :lisp) + +;;; perhaps this should use VAR, instead of NAME +(define-caller-pattern defvar + (var (:optional initial-value (:optional documentation-string))) + :lisp) +(define-caller-pattern defparameter + (var initial-value (:optional documentation-string)) + :lisp) +(define-caller-pattern defconstant + (var initial-value (:optional documentation-string)) + :lisp) + +(define-caller-pattern eval-when + (:ignore ; the situations + (:star form)) + :lisp) + +;;; Logical Values +(define-variable-pattern nil :lisp) +(define-variable-pattern t :lisp) + +;;; Predicates +(define-caller-pattern typep (form form) :lisp) +(define-caller-pattern subtypep (form form) :lisp) + +(define-caller-pattern null (form) :lisp) +(define-caller-pattern symbolp (form) :lisp) +(define-caller-pattern atom (form) :lisp) +(define-caller-pattern consp (form) :lisp) +(define-caller-pattern listp (form) :lisp) +(define-caller-pattern numberp (form) :lisp) +(define-caller-pattern integerp (form) :lisp) +(define-caller-pattern rationalp (form) :lisp) +(define-caller-pattern floatp (form) :lisp) +(define-caller-pattern realp (form) :lisp2) +(define-caller-pattern complexp (form) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern stringp (form) :lisp) +(define-caller-pattern bit-vector-p (form) :lisp) +(define-caller-pattern vectorp (form) :lisp) +(define-caller-pattern simple-vector-p (form) :lisp) +(define-caller-pattern simple-string-p (form) :lisp) +(define-caller-pattern simple-bit-vector-p (form) :lisp) +(define-caller-pattern arrayp (form) :lisp) +(define-caller-pattern packagep (form) :lisp) +(define-caller-pattern functionp (form) :lisp) +(define-caller-pattern compiled-function-p (form) :lisp) +(define-caller-pattern commonp (form) :lisp) + +;;; Equality Predicates +(define-caller-pattern eq (form form) :lisp) +(define-caller-pattern eql (form form) :lisp) +(define-caller-pattern equal (form form) :lisp) +(define-caller-pattern equalp (form form) :lisp) + +;;; Logical Operators +(define-caller-pattern not (form) :lisp) +(define-caller-pattern or ((:star form)) :lisp) +(define-caller-pattern and ((:star form)) :lisp) + +;;; Reference + +;;; Quote is a problem. In Defmacro & friends, we'd like to actually +;;; look at the argument, 'cause it hides internal function calls +;;; of the defmacro. +(define-caller-pattern quote (:ignore) :lisp) + +(define-caller-pattern function ((:or fn form)) :lisp) +(define-caller-pattern symbol-value (form) :lisp) +(define-caller-pattern symbol-function (form) :lisp) +(define-caller-pattern fdefinition (form) :lisp2) +(define-caller-pattern boundp (form) :lisp) +(define-caller-pattern fboundp (form) :lisp) +(define-caller-pattern special-form-p (form) :lisp) + +;;; Assignment +(define-caller-pattern setq ((:star var form)) :lisp) +(define-caller-pattern psetq ((:star var form)) :lisp) +(define-caller-pattern set (form form) :lisp) +(define-caller-pattern makunbound (form) :lisp) +(define-caller-pattern fmakunbound (form) :lisp) + +;;; Generalized Variables +(define-caller-pattern setf ((:star form form)) :lisp) +(define-caller-pattern psetf ((:star form form)) :lisp) +(define-caller-pattern shiftf ((:plus form) form) :lisp) +(define-caller-pattern rotatef ((:star form)) :lisp) +(define-caller-pattern define-modify-macro + (name + lambda-list + fn + (:optional documentation-string)) + :lisp) +(define-caller-pattern defsetf + (:or (name name (:optional documentation-string)) + (name lambda-list (var) + (:star (:or declaration documentation-string)) + (:star form))) + :lisp) +(define-caller-pattern define-setf-method + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern get-setf-method (form) :lisp) +(define-caller-pattern get-setf-method-multiple-value (form) :lisp) + + +;;; Function invocation +(define-caller-pattern apply (fn form (:star form)) :lisp) +(define-caller-pattern funcall (fn (:star form)) :lisp) + + +;;; Simple sequencing +(define-caller-pattern progn ((:star form)) :lisp) +(define-caller-pattern prog1 (form (:star form)) :lisp) +(define-caller-pattern prog2 (form form (:star form)) :lisp) + +;;; Variable bindings +(define-caller-pattern let + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern let* + (((:star (:or var (var &optional form)))) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern compiler-let + (((:star (:or var (var form)))) + (:star form)) + :lisp) +(define-caller-pattern progv + (form form (:star form)) :lisp) +(define-caller-pattern flet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern labels + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern macrolet + (((:star (name lambda-list + (:star (:or declaration + documentation-string)) + (:star form)))) + (:star form)) + :lisp) +(define-caller-pattern symbol-macrolet + (((:star (var form))) (:star declaration) (:star form)) + :lisp2) + +;;; Conditionals +(define-caller-pattern if (test form (:optional form)) :lisp) +(define-caller-pattern when (test (:star form)) :lisp) +(define-caller-pattern unless (test (:star form)) :lisp) +(define-caller-pattern cond ((:star (test (:star form)))) :lisp) +(define-caller-pattern case + (form + (:star ((:or symbol + ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern typecase (form (:star (symbol (:star form)))) + :lisp) + +;;; Blocks and Exits +(define-caller-pattern block (name (:star form)) :lisp) +(define-caller-pattern return-from (function (:optional form)) :lisp) +(define-caller-pattern return ((:optional form)) :lisp) + +;;; Iteration +(define-caller-pattern loop ((:star form)) :lisp) +(define-caller-pattern do + (((:star (:or var + (var (:optional form (:optional form)))))) ; init step + (form (:star form)) ; end-test result + (:star declaration) + (:star (:or tag form))) ; statement + :lisp) +(define-caller-pattern do* + (((:star (:or var + (var (:optional form (:optional form)))))) + (form (:star form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dolist + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern dotimes + ((var form (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) + +;;; Mapping +(define-caller-pattern mapcar (fn form (:star form)) :lisp) +(define-caller-pattern maplist (fn form (:star form)) :lisp) +(define-caller-pattern mapc (fn form (:star form)) :lisp) +(define-caller-pattern mapl (fn form (:star form)) :lisp) +(define-caller-pattern mapcan (fn form (:star form)) :lisp) +(define-caller-pattern mapcon (fn form (:star form)) :lisp) + +;;; The "Program Feature" +(define-caller-pattern tagbody ((:star (:or tag form))) :lisp) +(define-caller-pattern prog + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern prog* + (((:star (:or var (var (:optional form))))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern go (tag) :lisp) + +;;; Multiple Values +(define-caller-pattern values ((:star form)) :lisp) +(define-variable-pattern multiple-values-limit :lisp) +(define-caller-pattern values-list (form) :lisp) +(define-caller-pattern multiple-value-list (form) :lisp) +(define-caller-pattern multiple-value-call (fn (:star form)) :lisp) +(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp) +(define-caller-pattern multiple-value-bind + (((:star var)) form + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp) +(define-caller-pattern nth-value (form form) :lisp2) + +;;; Dynamic Non-Local Exits +(define-caller-pattern catch (tag (:star form)) :lisp) +(define-caller-pattern throw (tag form) :lisp) +(define-caller-pattern unwind-protect (form (:star form)) :lisp) + +;;; Macros +(define-caller-pattern macro-function (form) :lisp) +(define-caller-pattern defmacro + (name + lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp) +(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp) +(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp) +(define-variable-pattern *macroexpand-hook* :lisp) + +;;; Destructuring +(define-caller-pattern destructuring-bind + (lambda-list form + (:star declaration) + (:star form)) + :lisp2) + +;;; Compiler Macros +(define-caller-pattern define-compiler-macro + (name lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern compiler-macro-function (form) :lisp2) +(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2) +(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) + :lisp2) + +;;; Environments +(define-caller-pattern variable-information (form &optional :ignore) + :lisp2) +(define-caller-pattern function-information (fn &optional :ignore) :lisp2) +(define-caller-pattern declaration-information (form &optional :ignore) :lisp2) +(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2) +(define-caller-pattern define-declaration + (name + lambda-list + (:star form)) + :lisp2) +(define-caller-pattern parse-macro (name lambda-list form) :lisp2) +(define-caller-pattern enclose (form &optional :ignore) :lisp2) + + +;;; Declarations +(define-caller-pattern declare ((:rest :ignore)) :lisp) +(define-caller-pattern proclaim ((:rest :ignore)) :lisp) +(define-caller-pattern locally ((:star declaration) (:star form)) :lisp) +(define-caller-pattern declaim ((:rest :ignore)) :lisp2) +(define-caller-pattern the (form form) :lisp) + +;;; Symbols +(define-caller-pattern get (form form (:optional form)) :lisp) +(define-caller-pattern remprop (form form) :lisp) +(define-caller-pattern symbol-plist (form) :lisp) +(define-caller-pattern getf (form form (:optional form)) :lisp) +(define-caller-pattern remf (form form) :lisp) +(define-caller-pattern get-properties (form form) :lisp) + +(define-caller-pattern symbol-name (form) :lisp) +(define-caller-pattern make-symbol (form) :lisp) +(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp) +(define-caller-pattern gensym ((:optional :ignore)) :lisp) +(define-variable-pattern *gensym-counter* :lisp2) +(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp) +(define-caller-pattern symbol-package (form) :lisp) +(define-caller-pattern keywordp (form) :lisp) + +;;; Packages +(define-variable-pattern *package* :lisp) +(define-caller-pattern make-package ((:rest :ignore)) :lisp) +(define-caller-pattern in-package ((:rest :ignore)) :lisp) +(define-caller-pattern find-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-name ((:rest :ignore)) :lisp) +(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp) +(define-caller-pattern rename-package ((:rest :ignore)) :lisp) +(define-caller-pattern package-use-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp) +(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp) +(define-caller-pattern list-all-packages () :lisp) +(define-caller-pattern delete-package ((:rest :ignore)) :lisp2) +(define-caller-pattern intern (form &optional :ignore) :lisp) +(define-caller-pattern find-symbol (form &optional :ignore) :lisp) +(define-caller-pattern unintern (form &optional :ignore) :lisp) + +(define-caller-pattern export ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern unexport ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadowing-import ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) +(define-caller-pattern shadow ((:or symbol ((:star symbol))) + &optional :ignore) :lisp) + +(define-caller-pattern use-package ((:rest :ignore)) :lisp) +(define-caller-pattern unuse-package ((:rest :ignore)) :lisp) +(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2) +(define-caller-pattern find-all-symbols (form) :lisp) +(define-caller-pattern do-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-external-symbols + ((var (:optional form (:optional form))) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern do-all-symbols + ((var (:optional form)) + (:star declaration) + (:star (:or tag form))) + :lisp) +(define-caller-pattern with-package-iterator + ((name form (:plus :ignore)) + (:star form)) + :lisp2) + +;;; Modules +(define-variable-pattern *modules* :lisp) +(define-caller-pattern provide (form) :lisp) +(define-caller-pattern require (form &optional :ignore) :lisp) + + +;;; Numbers +(define-caller-pattern zerop (form) :lisp) +(define-caller-pattern plusp (form) :lisp) +(define-caller-pattern minusp (form) :lisp) +(define-caller-pattern oddp (form) :lisp) +(define-caller-pattern evenp (form) :lisp) + +(define-caller-pattern = (form (:star form)) :lisp) +(define-caller-pattern /= (form (:star form)) :lisp) +(define-caller-pattern > (form (:star form)) :lisp) +(define-caller-pattern < (form (:star form)) :lisp) +(define-caller-pattern <= (form (:star form)) :lisp) +(define-caller-pattern >= (form (:star form)) :lisp) + +(define-caller-pattern max (form (:star form)) :lisp) +(define-caller-pattern min (form (:star form)) :lisp) + +(define-caller-pattern - (form (:star form)) :lisp) +(define-caller-pattern + (form (:star form)) :lisp) +(define-caller-pattern * (form (:star form)) :lisp) +(define-caller-pattern / (form (:star form)) :lisp) +(define-caller-pattern 1+ (form) :lisp) +(define-caller-pattern 1- (form) :lisp) + +(define-caller-pattern incf (form form) :lisp) +(define-caller-pattern decf (form form) :lisp) + +(define-caller-pattern conjugate (form) :lisp) + +(define-caller-pattern gcd ((:star form)) :lisp) +(define-caller-pattern lcm ((:star form)) :lisp) + +(define-caller-pattern exp (form) :lisp) +(define-caller-pattern expt (form form) :lisp) +(define-caller-pattern log (form (:optional form)) :lisp) +(define-caller-pattern sqrt (form) :lisp) +(define-caller-pattern isqrt (form) :lisp) + +(define-caller-pattern abs (form) :lisp) +(define-caller-pattern phase (form) :lisp) +(define-caller-pattern signum (form) :lisp) +(define-caller-pattern sin (form) :lisp) +(define-caller-pattern cos (form) :lisp) +(define-caller-pattern tan (form) :lisp) +(define-caller-pattern cis (form) :lisp) +(define-caller-pattern asin (form) :lisp) +(define-caller-pattern acos (form) :lisp) +(define-caller-pattern atan (form &optional form) :lisp) +(define-variable-pattern pi :lisp) + +(define-caller-pattern sinh (form) :lisp) +(define-caller-pattern cosh (form) :lisp) +(define-caller-pattern tanh (form) :lisp) +(define-caller-pattern asinh (form) :lisp) +(define-caller-pattern acosh (form) :lisp) +(define-caller-pattern atanh (form) :lisp) + +;;; Type Conversions and Extractions +(define-caller-pattern float (form (:optional form)) :lisp) +(define-caller-pattern rational (form) :lisp) +(define-caller-pattern rationalize (form) :lisp) +(define-caller-pattern numerator (form) :lisp) +(define-caller-pattern denominator (form) :lisp) + +(define-caller-pattern floor (form (:optional form)) :lisp) +(define-caller-pattern ceiling (form (:optional form)) :lisp) +(define-caller-pattern truncate (form (:optional form)) :lisp) +(define-caller-pattern round (form (:optional form)) :lisp) + +(define-caller-pattern mod (form form) :lisp) +(define-caller-pattern rem (form form) :lisp) + +(define-caller-pattern ffloor (form (:optional form)) :lisp) +(define-caller-pattern fceiling (form (:optional form)) :lisp) +(define-caller-pattern ftruncate (form (:optional form)) :lisp) +(define-caller-pattern fround (form (:optional form)) :lisp) + +(define-caller-pattern decode-float (form) :lisp) +(define-caller-pattern scale-float (form form) :lisp) +(define-caller-pattern float-radix (form) :lisp) +(define-caller-pattern float-sign (form (:optional form)) :lisp) +(define-caller-pattern float-digits (form) :lisp) +(define-caller-pattern float-precision (form) :lisp) +(define-caller-pattern integer-decode-float (form) :lisp) + +(define-caller-pattern complex (form (:optional form)) :lisp) +(define-caller-pattern realpart (form) :lisp) +(define-caller-pattern imagpart (form) :lisp) + +(define-caller-pattern logior ((:star form)) :lisp) +(define-caller-pattern logxor ((:star form)) :lisp) +(define-caller-pattern logand ((:star form)) :lisp) +(define-caller-pattern logeqv ((:star form)) :lisp) + +(define-caller-pattern lognand (form form) :lisp) +(define-caller-pattern lognor (form form) :lisp) +(define-caller-pattern logandc1 (form form) :lisp) +(define-caller-pattern logandc2 (form form) :lisp) +(define-caller-pattern logorc1 (form form) :lisp) +(define-caller-pattern logorc2 (form form) :lisp) + +(define-caller-pattern boole (form form form) :lisp) +(define-variable-pattern boole-clr :lisp) +(define-variable-pattern boole-set :lisp) +(define-variable-pattern boole-1 :lisp) +(define-variable-pattern boole-2 :lisp) +(define-variable-pattern boole-c1 :lisp) +(define-variable-pattern boole-c2 :lisp) +(define-variable-pattern boole-and :lisp) +(define-variable-pattern boole-ior :lisp) +(define-variable-pattern boole-xor :lisp) +(define-variable-pattern boole-eqv :lisp) +(define-variable-pattern boole-nand :lisp) +(define-variable-pattern boole-nor :lisp) +(define-variable-pattern boole-andc1 :lisp) +(define-variable-pattern boole-andc2 :lisp) +(define-variable-pattern boole-orc1 :lisp) +(define-variable-pattern boole-orc2 :lisp) + +(define-caller-pattern lognot (form) :lisp) +(define-caller-pattern logtest (form form) :lisp) +(define-caller-pattern logbitp (form form) :lisp) +(define-caller-pattern ash (form form) :lisp) +(define-caller-pattern logcount (form) :lisp) +(define-caller-pattern integer-length (form) :lisp) + +(define-caller-pattern byte (form form) :lisp) +(define-caller-pattern byte-size (form) :lisp) +(define-caller-pattern byte-position (form) :lisp) +(define-caller-pattern ldb (form form) :lisp) +(define-caller-pattern ldb-test (form form) :lisp) +(define-caller-pattern mask-field (form form) :lisp) +(define-caller-pattern dpb (form form form) :lisp) +(define-caller-pattern deposit-field (form form form) :lisp) + +;;; Random Numbers +(define-caller-pattern random (form (:optional form)) :lisp) +(define-variable-pattern *random-state* :lisp) +(define-caller-pattern make-random-state ((:optional form)) :lisp) +(define-caller-pattern random-state-p (form) :lisp) + +;;; Implementation Parameters +(define-variable-pattern most-positive-fixnum :lisp) +(define-variable-pattern most-negative-fixnum :lisp) +(define-variable-pattern most-positive-short-float :lisp) +(define-variable-pattern least-positive-short-float :lisp) +(define-variable-pattern least-negative-short-float :lisp) +(define-variable-pattern most-negative-short-float :lisp) +(define-variable-pattern most-positive-single-float :lisp) +(define-variable-pattern least-positive-single-float :lisp) +(define-variable-pattern least-negative-single-float :lisp) +(define-variable-pattern most-negative-single-float :lisp) +(define-variable-pattern most-positive-double-float :lisp) +(define-variable-pattern least-positive-double-float :lisp) +(define-variable-pattern least-negative-double-float :lisp) +(define-variable-pattern most-negative-double-float :lisp) +(define-variable-pattern most-positive-long-float :lisp) +(define-variable-pattern least-positive-long-float :lisp) +(define-variable-pattern least-negative-long-float :lisp) +(define-variable-pattern most-negative-long-float :lisp) +(define-variable-pattern least-positive-normalized-short-float :lisp2) +(define-variable-pattern least-negative-normalized-short-float :lisp2) +(define-variable-pattern least-positive-normalized-single-float :lisp2) +(define-variable-pattern least-negative-normalized-single-float :lisp2) +(define-variable-pattern least-positive-normalized-double-float :lisp2) +(define-variable-pattern least-negative-normalized-double-float :lisp2) +(define-variable-pattern least-positive-normalized-long-float :lisp2) +(define-variable-pattern least-negative-normalized-long-float :lisp2) +(define-variable-pattern short-float-epsilon :lisp) +(define-variable-pattern single-float-epsilon :lisp) +(define-variable-pattern double-float-epsilon :lisp) +(define-variable-pattern long-float-epsilon :lisp) +(define-variable-pattern short-float-negative-epsilon :lisp) +(define-variable-pattern single-float-negative-epsilon :lisp) +(define-variable-pattern double-float-negative-epsilon :lisp) +(define-variable-pattern long-float-negative-epsilon :lisp) + +;;; Characters +(define-variable-pattern char-code-limit :lisp) +(define-variable-pattern char-font-limit :lisp) +(define-variable-pattern char-bits-limit :lisp) +(define-caller-pattern standard-char-p (form) :lisp) +(define-caller-pattern graphic-char-p (form) :lisp) +(define-caller-pattern string-char-p (form) :lisp) +(define-caller-pattern alpha-char-p (form) :lisp) +(define-caller-pattern upper-case-p (form) :lisp) +(define-caller-pattern lower-case-p (form) :lisp) +(define-caller-pattern both-case-p (form) :lisp) +(define-caller-pattern digit-char-p (form (:optional form)) :lisp) +(define-caller-pattern alphanumericp (form) :lisp) + +(define-caller-pattern char= ((:star form)) :lisp) +(define-caller-pattern char/= ((:star form)) :lisp) +(define-caller-pattern char< ((:star form)) :lisp) +(define-caller-pattern char> ((:star form)) :lisp) +(define-caller-pattern char<= ((:star form)) :lisp) +(define-caller-pattern char>= ((:star form)) :lisp) + +(define-caller-pattern char-equal ((:star form)) :lisp) +(define-caller-pattern char-not-equal ((:star form)) :lisp) +(define-caller-pattern char-lessp ((:star form)) :lisp) +(define-caller-pattern char-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-greaterp ((:star form)) :lisp) +(define-caller-pattern char-not-lessp ((:star form)) :lisp) + +(define-caller-pattern char-code (form) :lisp) +(define-caller-pattern char-bits (form) :lisp) +(define-caller-pattern char-font (form) :lisp) +(define-caller-pattern code-char (form (:optional form form)) :lisp) +(define-caller-pattern make-char (form (:optional form form)) :lisp) +(define-caller-pattern characterp (form) :lisp) +(define-caller-pattern char-upcase (form) :lisp) +(define-caller-pattern char-downcase (form) :lisp) +(define-caller-pattern digit-char (form (:optional form form)) :lisp) +(define-caller-pattern char-int (form) :lisp) +(define-caller-pattern int-char (form) :lisp) +(define-caller-pattern char-name (form) :lisp) +(define-caller-pattern name-char (form) :lisp) +(define-variable-pattern char-control-bit :lisp) +(define-variable-pattern char-meta-bit :lisp) +(define-variable-pattern char-super-bit :lisp) +(define-variable-pattern char-hyper-bit :lisp) +(define-caller-pattern char-bit (form form) :lisp) +(define-caller-pattern set-char-bit (form form form) :lisp) + +;;; Sequences +(define-caller-pattern complement (fn) :lisp2) +(define-caller-pattern elt (form form) :lisp) +(define-caller-pattern subseq (form form &optional form) :lisp) +(define-caller-pattern copy-seq (form) :lisp) +(define-caller-pattern length (form) :lisp) +(define-caller-pattern reverse (form) :lisp) +(define-caller-pattern nreverse (form) :lisp) +(define-caller-pattern make-sequence (form form &key form) :lisp) + +(define-caller-pattern concatenate (form (:star form)) :lisp) +(define-caller-pattern map (form fn form (:star form)) :lisp) +(define-caller-pattern map-into (form fn (:star form)) :lisp2) + +(define-caller-pattern some (fn form (:star form)) :lisp) +(define-caller-pattern every (fn form (:star form)) :lisp) +(define-caller-pattern notany (fn form (:star form)) :lisp) +(define-caller-pattern notevery (fn form (:star form)) :lisp) + +(define-caller-pattern reduce (fn form &key (:star form)) :lisp) +(define-caller-pattern fill (form form &key (:star form)) :lisp) +(define-caller-pattern replace (form form &key (:star form)) :lisp) +(define-caller-pattern remove (form form &key (:star form)) :lisp) +(define-caller-pattern remove-if (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern delete (form form &key (:star form)) :lisp) +(define-caller-pattern delete-if (fn form &key (:star form)) :lisp) +(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp) +(define-caller-pattern substitute (form form form &key (:star form)) :lisp) +(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern substitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) + :lisp) +(define-caller-pattern find (form form &key (:star form)) :lisp) +(define-caller-pattern find-if (fn form &key (:star form)) :lisp) +(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern position (form form &key (:star form)) :lisp) +(define-caller-pattern position-if (fn form &key (:star form)) :lisp) +(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern count (form form &key (:star form)) :lisp) +(define-caller-pattern count-if (fn form &key (:star form)) :lisp) +(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp) +(define-caller-pattern mismatch (form form &key (:star form)) :lisp) +(define-caller-pattern search (form form &key (:star form)) :lisp) +(define-caller-pattern sort (form fn &key (:star form)) :lisp) +(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp) +(define-caller-pattern merge (form form form fn &key (:star form)) :lisp) + +;;; Lists +(define-caller-pattern car (form) :lisp) +(define-caller-pattern cdr (form) :lisp) +(define-caller-pattern caar (form) :lisp) +(define-caller-pattern cadr (form) :lisp) +(define-caller-pattern cdar (form) :lisp) +(define-caller-pattern cddr (form) :lisp) +(define-caller-pattern caaar (form) :lisp) +(define-caller-pattern caadr (form) :lisp) +(define-caller-pattern cadar (form) :lisp) +(define-caller-pattern caddr (form) :lisp) +(define-caller-pattern cdaar (form) :lisp) +(define-caller-pattern cdadr (form) :lisp) +(define-caller-pattern cddar (form) :lisp) +(define-caller-pattern cdddr (form) :lisp) +(define-caller-pattern caaaar (form) :lisp) +(define-caller-pattern caaadr (form) :lisp) +(define-caller-pattern caadar (form) :lisp) +(define-caller-pattern caaddr (form) :lisp) +(define-caller-pattern cadaar (form) :lisp) +(define-caller-pattern cadadr (form) :lisp) +(define-caller-pattern caddar (form) :lisp) +(define-caller-pattern cadddr (form) :lisp) +(define-caller-pattern cdaaar (form) :lisp) +(define-caller-pattern cdaadr (form) :lisp) +(define-caller-pattern cdadar (form) :lisp) +(define-caller-pattern cdaddr (form) :lisp) +(define-caller-pattern cddaar (form) :lisp) +(define-caller-pattern cddadr (form) :lisp) +(define-caller-pattern cdddar (form) :lisp) +(define-caller-pattern cddddr (form) :lisp) + +(define-caller-pattern cons (form form) :lisp) +(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp) +(define-caller-pattern endp (form) :lisp) +(define-caller-pattern list-length (form) :lisp) +(define-caller-pattern nth (form form) :lisp) + +(define-caller-pattern first (form) :lisp) +(define-caller-pattern second (form) :lisp) +(define-caller-pattern third (form) :lisp) +(define-caller-pattern fourth (form) :lisp) +(define-caller-pattern fifth (form) :lisp) +(define-caller-pattern sixth (form) :lisp) +(define-caller-pattern seventh (form) :lisp) +(define-caller-pattern eighth (form) :lisp) +(define-caller-pattern ninth (form) :lisp) +(define-caller-pattern tenth (form) :lisp) + +(define-caller-pattern rest (form) :lisp) +(define-caller-pattern nthcdr (form form) :lisp) +(define-caller-pattern last (form (:optional form)) :lisp) +(define-caller-pattern list ((:star form)) :lisp) +(define-caller-pattern list* ((:star form)) :lisp) +(define-caller-pattern make-list (form &key (:star form)) :lisp) +(define-caller-pattern append ((:star form)) :lisp) +(define-caller-pattern copy-list (form) :lisp) +(define-caller-pattern copy-alist (form) :lisp) +(define-caller-pattern copy-tree (form) :lisp) +(define-caller-pattern revappend (form form) :lisp) +(define-caller-pattern nconc ((:star form)) :lisp) +(define-caller-pattern nreconc (form form) :lisp) +(define-caller-pattern push (form form) :lisp) +(define-caller-pattern pushnew (form form &key (:star form)) :lisp) +(define-caller-pattern pop (form) :lisp) +(define-caller-pattern butlast (form (:optional form)) :lisp) +(define-caller-pattern nbutlast (form (:optional form)) :lisp) +(define-caller-pattern ldiff (form form) :lisp) +(define-caller-pattern rplaca (form form) :lisp) +(define-caller-pattern rplacd (form form) :lisp) + +(define-caller-pattern subst (form form form &key (:star form)) :lisp) +(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst (form form form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp) +(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp) +(define-caller-pattern sublis (form form &key (:star form)) :lisp) +(define-caller-pattern nsublis (form form &key (:star form)) :lisp) +(define-caller-pattern member (form form &key (:star form)) :lisp) +(define-caller-pattern member-if (fn form &key (:star form)) :lisp) +(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp) + +(define-caller-pattern tailp (form form) :lisp) +(define-caller-pattern adjoin (form form &key (:star form)) :lisp) +(define-caller-pattern union (form form &key (:star form)) :lisp) +(define-caller-pattern nunion (form form &key (:star form)) :lisp) +(define-caller-pattern intersection (form form &key (:star form)) :lisp) +(define-caller-pattern nintersection (form form &key (:star form)) :lisp) +(define-caller-pattern set-difference (form form &key (:star form)) :lisp) +(define-caller-pattern nset-difference (form form &key (:star form)) :lisp) +(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp) +(define-caller-pattern subsetp (form form &key (:star form)) :lisp) + +(define-caller-pattern acons (form form form) :lisp) +(define-caller-pattern pairlis (form form (:optional form)) :lisp) +(define-caller-pattern assoc (form form &key (:star form)) :lisp) +(define-caller-pattern assoc-if (fn form) :lisp) +(define-caller-pattern assoc-if-not (fn form) :lisp) +(define-caller-pattern rassoc (form form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp) +(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp) + +;;; Hash Tables +(define-caller-pattern make-hash-table (&key (:star form)) :lisp) +(define-caller-pattern hash-table-p (form) :lisp) +(define-caller-pattern gethash (form form (:optional form)) :lisp) +(define-caller-pattern remhash (form form) :lisp) +(define-caller-pattern maphash (fn form) :lisp) +(define-caller-pattern clrhash (form) :lisp) +(define-caller-pattern hash-table-count (form) :lisp) +(define-caller-pattern with-hash-table-iterator + ((name form) (:star form)) :lisp2) +(define-caller-pattern hash-table-rehash-size (form) :lisp2) +(define-caller-pattern hash-table-rehash-threshold (form) :lisp2) +(define-caller-pattern hash-table-size (form) :lisp2) +(define-caller-pattern hash-table-test (form) :lisp2) +(define-caller-pattern sxhash (form) :lisp) + +;;; Arrays +(define-caller-pattern make-array (form &key (:star form)) :lisp) +(define-variable-pattern array-rank-limit :lisp) +(define-variable-pattern array-dimension-limit :lisp) +(define-variable-pattern array-total-size-limit :lisp) +(define-caller-pattern vector ((:star form)) :lisp) +(define-caller-pattern aref (form (:star form)) :lisp) +(define-caller-pattern svref (form form) :lisp) +(define-caller-pattern array-element-type (form) :lisp) +(define-caller-pattern array-rank (form) :lisp) +(define-caller-pattern array-dimension (form form) :lisp) +(define-caller-pattern array-dimensions (form) :lisp) +(define-caller-pattern array-total-size (form) :lisp) +(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp) +(define-caller-pattern array-row-major-index (form (:star form)) :lisp) +(define-caller-pattern row-major-aref (form form) :lisp2) +(define-caller-pattern adjustable-array-p (form) :lisp) + +(define-caller-pattern bit (form (:star form)) :lisp) +(define-caller-pattern sbit (form (:star form)) :lisp) + +(define-caller-pattern bit-and (form form (:optional form)) :lisp) +(define-caller-pattern bit-ior (form form (:optional form)) :lisp) +(define-caller-pattern bit-xor (form form (:optional form)) :lisp) +(define-caller-pattern bit-eqv (form form (:optional form)) :lisp) +(define-caller-pattern bit-nand (form form (:optional form)) :lisp) +(define-caller-pattern bit-nor (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp) +(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp) +(define-caller-pattern bit-not (form (:optional form)) :lisp) + +(define-caller-pattern array-has-fill-pointer-p (form) :lisp) +(define-caller-pattern fill-pointer (form) :lisp) +(define-caller-pattern vector-push (form form) :lisp) +(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp) +(define-caller-pattern vector-pop (form) :lisp) +(define-caller-pattern adjust-array (form form &key (:star form)) :lisp) + +;;; Strings +(define-caller-pattern char (form form) :lisp) +(define-caller-pattern schar (form form) :lisp) +(define-caller-pattern string= (form form &key (:star form)) :lisp) +(define-caller-pattern string-equal (form form &key (:star form)) :lisp) +(define-caller-pattern string< (form form &key (:star form)) :lisp) +(define-caller-pattern string> (form form &key (:star form)) :lisp) +(define-caller-pattern string<= (form form &key (:star form)) :lisp) +(define-caller-pattern string>= (form form &key (:star form)) :lisp) +(define-caller-pattern string/= (form form &key (:star form)) :lisp) +(define-caller-pattern string-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp) +(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp) + +(define-caller-pattern make-string (form &key (:star form)) :lisp) +(define-caller-pattern string-trim (form form) :lisp) +(define-caller-pattern string-left-trim (form form) :lisp) +(define-caller-pattern string-right-trim (form form) :lisp) +(define-caller-pattern string-upcase (form &key (:star form)) :lisp) +(define-caller-pattern string-downcase (form &key (:star form)) :lisp) +(define-caller-pattern string-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp) +(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp) +(define-caller-pattern string (form) :lisp) + +;;; Structures +(define-caller-pattern defstruct + ((:or name (name (:rest :ignore))) + (:optional documentation-string) + (:plus :ignore)) + :lisp) + +;;; The Evaluator +(define-caller-pattern eval (form) :lisp) +(define-variable-pattern *evalhook* :lisp) +(define-variable-pattern *applyhook* :lisp) +(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp) +(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp) +(define-caller-pattern constantp (form) :lisp) + +;;; Streams +(define-variable-pattern *standard-input* :lisp) +(define-variable-pattern *standard-output* :lisp) +(define-variable-pattern *error-output* :lisp) +(define-variable-pattern *query-io* :lisp) +(define-variable-pattern *debug-io* :lisp) +(define-variable-pattern *terminal-io* :lisp) +(define-variable-pattern *trace-output* :lisp) +(define-caller-pattern make-synonym-stream (symbol) :lisp) +(define-caller-pattern make-broadcast-stream ((:star form)) :lisp) +(define-caller-pattern make-concatenated-stream ((:star form)) :lisp) +(define-caller-pattern make-two-way-stream (form form) :lisp) +(define-caller-pattern make-echo-stream (form form) :lisp) +(define-caller-pattern make-string-input-stream (form &optional form form) + :lisp) +(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp) +(define-caller-pattern get-output-stream-string (form) :lisp) + +(define-caller-pattern with-open-stream + ((var form) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-input-from-string + ((var form &key (:star form)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern with-output-to-string + ((var (:optional form)) + (:star declaration) + (:star form)) + :lisp) +(define-caller-pattern streamp (form) :lisp) +(define-caller-pattern open-stream-p (form) :lisp2) +(define-caller-pattern input-stream-p (form) :lisp) +(define-caller-pattern output-stream-p (form) :lisp) +(define-caller-pattern stream-element-type (form) :lisp) +(define-caller-pattern close (form (:rest :ignore)) :lisp) +(define-caller-pattern broadcast-stream-streams (form) :lisp2) +(define-caller-pattern concatenated-stream-streams (form) :lisp2) +(define-caller-pattern echo-stream-input-stream (form) :lisp2) +(define-caller-pattern echo-stream-output-stream (form) :lisp2) +(define-caller-pattern synonym-stream-symbol (form) :lisp2) +(define-caller-pattern two-way-stream-input-stream (form) :lisp2) +(define-caller-pattern two-way-stream-output-stream (form) :lisp2) +(define-caller-pattern interactive-stream-p (form) :lisp2) +(define-caller-pattern stream-external-format (form) :lisp2) + +;;; Reader +(define-variable-pattern *read-base* :lisp) +(define-variable-pattern *read-suppress* :lisp) +(define-variable-pattern *read-eval* :lisp2) +(define-variable-pattern *readtable* :lisp) +(define-caller-pattern copy-readtable (&optional form form) :lisp) +(define-caller-pattern readtablep (form) :lisp) +(define-caller-pattern set-syntax-from-char (form form &optional form form) + :lisp) +(define-caller-pattern set-macro-character (form fn &optional form) :lisp) +(define-caller-pattern get-macro-character (form (:optional form)) :lisp) +(define-caller-pattern make-dispatch-macro-character (form &optional form form) + :lisp) +(define-caller-pattern set-dispatch-macro-character + (form form fn (:optional form)) :lisp) +(define-caller-pattern get-dispatch-macro-character + (form form (:optional form)) :lisp) +(define-caller-pattern readtable-case (form) :lisp2) +(define-variable-pattern *print-readably* :lisp2) +(define-variable-pattern *print-escape* :lisp) +(define-variable-pattern *print-pretty* :lisp) +(define-variable-pattern *print-circle* :lisp) +(define-variable-pattern *print-base* :lisp) +(define-variable-pattern *print-radix* :lisp) +(define-variable-pattern *print-case* :lisp) +(define-variable-pattern *print-gensym* :lisp) +(define-variable-pattern *print-level* :lisp) +(define-variable-pattern *print-length* :lisp) +(define-variable-pattern *print-array* :lisp) +(define-caller-pattern with-standard-io-syntax + ((:star declaration) + (:star form)) + :lisp2) + +(define-caller-pattern read (&optional form form form form) :lisp) +(define-variable-pattern *read-default-float-format* :lisp) +(define-caller-pattern read-preserving-whitespace + (&optional form form form form) :lisp) +(define-caller-pattern read-delimited-list (form &optional form form) :lisp) +(define-caller-pattern read-line (&optional form form form form) :lisp) +(define-caller-pattern read-char (&optional form form form form) :lisp) +(define-caller-pattern unread-char (form (:optional form)) :lisp) +(define-caller-pattern peek-char (&optional form form form form) :lisp) +(define-caller-pattern listen ((:optional form)) :lisp) +(define-caller-pattern read-char-no-hang ((:star form)) :lisp) +(define-caller-pattern clear-input ((:optional form)) :lisp) +(define-caller-pattern read-from-string (form (:star form)) :lisp) +(define-caller-pattern parse-integer (form &rest :ignore) :lisp) +(define-caller-pattern read-byte ((:star form)) :lisp) + +(define-caller-pattern write (form &key (:star form)) :lisp) +(define-caller-pattern prin1 (form (:optional form)) :lisp) +(define-caller-pattern print (form (:optional form)) :lisp) +(define-caller-pattern pprint (form (:optional form)) :lisp) +(define-caller-pattern princ (form (:optional form)) :lisp) +(define-caller-pattern write-to-string (form &key (:star form)) :lisp) +(define-caller-pattern prin1-to-string (form) :lisp) +(define-caller-pattern princ-to-string (form) :lisp) +(define-caller-pattern write-char (form (:optional form)) :lisp) +(define-caller-pattern write-string (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern write-line (form &optional form &key (:star form)) + :lisp) +(define-caller-pattern terpri ((:optional form)) :lisp) +(define-caller-pattern fresh-line ((:optional form)) :lisp) +(define-caller-pattern finish-output ((:optional form)) :lisp) +(define-caller-pattern force-output ((:optional form)) :lisp) +(define-caller-pattern clear-output ((:optional form)) :lisp) +(define-caller-pattern print-unreadable-object + ((form form &key (:star form)) + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern write-byte (form form) :lisp) +(define-caller-pattern format + (destination + control-string + (:rest format-arguments)) + :lisp) + +(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp) +(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp) + +;;; Pathnames +(define-caller-pattern wild-pathname-p (form &optional form) :lisp2) +(define-caller-pattern pathname-match-p (form form) :lisp2) +(define-caller-pattern translate-pathname (form form form &key (:star form)) + :lisp2) + +(define-caller-pattern logical-pathname (form) :lisp2) +(define-caller-pattern translate-logical-pathname (form &key (:star form)) + :lisp2) +(define-caller-pattern logical-pathname-translations (form) :lisp2) +(define-caller-pattern load-logical-pathname-translations (form) :lisp2) +(define-caller-pattern compile-file-pathname (form &key form) :lisp2) + +(define-caller-pattern pathname (form) :lisp) +(define-caller-pattern truename (form) :lisp) +(define-caller-pattern parse-namestring ((:star form)) :lisp) +(define-caller-pattern merge-pathnames ((:star form)) :lisp) +(define-variable-pattern *default-pathname-defaults* :lisp) +(define-caller-pattern make-pathname ((:star form)) :lisp) +(define-caller-pattern pathnamep (form) :lisp) +(define-caller-pattern pathname-host (form) :lisp) +(define-caller-pattern pathname-device (form) :lisp) +(define-caller-pattern pathname-directory (form) :lisp) +(define-caller-pattern pathname-name (form) :lisp) +(define-caller-pattern pathname-type (form) :lisp) +(define-caller-pattern pathname-version (form) :lisp) +(define-caller-pattern namestring (form) :lisp) +(define-caller-pattern file-namestring (form) :lisp) +(define-caller-pattern directory-namestring (form) :lisp) +(define-caller-pattern host-namestring (form) :lisp) +(define-caller-pattern enough-namestring (form (:optional form)) :lisp) +(define-caller-pattern user-homedir-pathname (&optional form) :lisp) +(define-caller-pattern open (form &key (:star form)) :lisp) +(define-caller-pattern with-open-file + ((var form (:rest :ignore)) + (:star declaration) + (:star form)) + :lisp) + +(define-caller-pattern rename-file (form form) :lisp) +(define-caller-pattern delete-file (form) :lisp) +(define-caller-pattern probe-file (form) :lisp) +(define-caller-pattern file-write-date (form) :lisp) +(define-caller-pattern file-author (form) :lisp) +(define-caller-pattern file-position (form (:optional form)) :lisp) +(define-caller-pattern file-length (form) :lisp) +(define-caller-pattern file-string-length (form form) :lisp2) +(define-caller-pattern load (form &key (:star form)) :lisp) +(define-variable-pattern *load-verbose* :lisp) +(define-variable-pattern *load-print* :lisp2) +(define-variable-pattern *load-pathname* :lisp2) +(define-variable-pattern *load-truename* :lisp2) +(define-caller-pattern make-load-form (form) :lisp2) +(define-caller-pattern make-load-form-saving-slots (form &optional form) + :lisp2) +(define-caller-pattern directory (form &key (:star form)) :lisp) + +;;; Errors +(define-caller-pattern error (form (:star form)) :lisp) +(define-caller-pattern cerror (form form (:star form)) :lisp) +(define-caller-pattern warn (form (:star form)) :lisp) +(define-variable-pattern *break-on-warnings* :lisp) +(define-caller-pattern break (&optional form (:star form)) :lisp) +(define-caller-pattern check-type (form form (:optional form)) :lisp) +(define-caller-pattern assert + (form + (:optional ((:star var)) + (:optional form (:star form)))) + :lisp) +(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp) +(define-caller-pattern ecase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) +(define-caller-pattern ccase + (form + (:star ((:or symbol ((:star symbol))) + (:star form)))) + :lisp) + +;;; The Compiler +(define-caller-pattern compile (form (:optional form)) :lisp) +(define-caller-pattern compile-file (form &key (:star form)) :lisp) +(define-variable-pattern *compile-verbose* :lisp2) +(define-variable-pattern *compile-print* :lisp2) +(define-variable-pattern *compile-file-pathname* :lisp2) +(define-variable-pattern *compile-file-truename* :lisp2) +(define-caller-pattern load-time-value (form (:optional form)) :lisp2) +(define-caller-pattern disassemble (form) :lisp) +(define-caller-pattern function-lambda-expression (fn) :lisp2) +(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) + :lisp2) + +;;; Documentation +(define-caller-pattern documentation (form form) :lisp) +(define-caller-pattern trace ((:star form)) :lisp) +(define-caller-pattern untrace ((:star form)) :lisp) +(define-caller-pattern step (form) :lisp) +(define-caller-pattern time (form) :lisp) +(define-caller-pattern describe (form &optional form) :lisp) +(define-caller-pattern describe-object (form &optional form) :lisp2) +(define-caller-pattern inspect (form) :lisp) +(define-caller-pattern room ((:optional form)) :lisp) +(define-caller-pattern ed ((:optional form)) :lisp) +(define-caller-pattern dribble ((:optional form)) :lisp) +(define-caller-pattern apropos (form (:optional form)) :lisp) +(define-caller-pattern apropos-list (form (:optional form)) :lisp) +(define-caller-pattern get-decoded-time () :lisp) +(define-caller-pattern get-universal-time () :lisp) +(define-caller-pattern decode-universal-time (form &optional form) :lisp) +(define-caller-pattern encode-universal-time + (form form form form form form &optional form) :lisp) +(define-caller-pattern get-internal-run-time () :lisp) +(define-caller-pattern get-internal-real-time () :lisp) +(define-caller-pattern sleep (form) :lisp) + +(define-caller-pattern lisp-implementation-type () :lisp) +(define-caller-pattern lisp-implementation-version () :lisp) +(define-caller-pattern machine-type () :lisp) +(define-caller-pattern machine-version () :lisp) +(define-caller-pattern machine-instance () :lisp) +(define-caller-pattern software-type () :lisp) +(define-caller-pattern software-version () :lisp) +(define-caller-pattern short-site-name () :lisp) +(define-caller-pattern long-site-name () :lisp) +(define-variable-pattern *features* :lisp) + +(define-caller-pattern identity (form) :lisp) + +;;; Pretty Printing +(define-variable-pattern *print-pprint-dispatch* :lisp2) +(define-variable-pattern *print-right-margin* :lisp2) +(define-variable-pattern *print-miser-width* :lisp2) +(define-variable-pattern *print-lines* :lisp2) +(define-caller-pattern pprint-newline (form &optional form) :lisp2) +(define-caller-pattern pprint-logical-block + ((var form &key (:star form)) + (:star form)) + :lisp2) +(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2) +(define-caller-pattern pprint-pop () :lisp2) +(define-caller-pattern pprint-indent (form form &optional form) :lisp2) +(define-caller-pattern pprint-tab (form form form &optional form) :lisp2) +(define-caller-pattern pprint-fill (form form &optional form form) :lisp2) +(define-caller-pattern pprint-linear (form form &optional form form) :lisp2) +(define-caller-pattern pprint-tabular (form form &optional form form form) + :lisp2) +(define-caller-pattern formatter (control-string) :lisp2) +(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2) +(define-caller-pattern pprint-dispatch (form &optional form) :lisp2) +(define-caller-pattern set-pprint-dispatch (form form &optional form form) + :lisp2) + +;;; CLOS +(define-caller-pattern add-method (fn form) :lisp2) +(define-caller-pattern call-method (form form) :lisp2) +(define-caller-pattern call-next-method ((:star form)) :lisp2) +(define-caller-pattern change-class (form form) :lisp2) +(define-caller-pattern class-name (form) :lisp2) +(define-caller-pattern class-of (form) :lisp2) +(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2) +(define-caller-pattern defclass (name &rest :ignore) :lisp2) +(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2) +(define-caller-pattern define-method-combination + (name lambda-list ((:star :ignore)) + (:optional ((:eq :arguments) :ignore)) + (:optional ((:eq :generic-function) :ignore)) + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern defmethod + (name (:star symbol) lambda-list + (:star (:or declaration documentation-string)) + (:star form)) + :lisp2) +(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2) +(define-caller-pattern find-class (form &optional form form) :lisp2) +(define-caller-pattern find-method (fn &rest :ignore) :lisp2) +(define-caller-pattern function-keywords (&rest :ignore) :lisp2) +(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-labels + (((:star (name lambda-list))) (:star form)) + :lisp2) +(define-caller-pattern generic-function (lambda-list) :lisp2) +(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2) +(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2) +(define-caller-pattern make-instance (fn (:star form)) :lisp2) +(define-caller-pattern make-instances-obsolete (fn) :lisp2) +(define-caller-pattern method-combination-error (form (:star form)) :lisp2) +(define-caller-pattern method-qualifiers (fn) :lisp2) +(define-caller-pattern next-method-p () :lisp2) +(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2) +(define-caller-pattern no-next-method (fn (:star form)) :lisp2) +(define-caller-pattern print-object (form form) :lisp2) +(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2) +(define-caller-pattern remove-method (fn form) :lisp2) +(define-caller-pattern shared-initialize (form form (:star form)) :lisp2) +(define-caller-pattern slot-boundp (form form) :lisp2) +(define-caller-pattern slot-exists-p (form form) :lisp2) +(define-caller-pattern slot-makeunbound (form form) :lisp2) +(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2) +(define-caller-pattern slot-unbound (fn form form) :lisp2) +(define-caller-pattern slot-value (form form) :lisp2) +(define-caller-pattern update-instance-for-different-class + (form form (:star form)) :lisp2) +(define-caller-pattern update-instance-for-redefined-class + (form form (:star form)) :lisp2) +(define-caller-pattern with-accessors + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern with-added-methods + ((name lambda-list) form + (:star form)) + :lisp2) +(define-caller-pattern with-slots + (((:star :ignore)) form + (:star declaration) + (:star form)) + :lisp2) + +;;; Conditions +(define-caller-pattern signal (form (:star form)) :lisp2) +(define-variable-pattern *break-on-signals* :lisp2) +(define-caller-pattern handler-case (form (:star (form ((:optional var)) + (:star form)))) + :lisp2) +(define-caller-pattern ignore-errors ((:star form)) :lisp2) +(define-caller-pattern handler-bind (((:star (form form))) + (:star form)) + :lisp2) +(define-caller-pattern define-condition (name &rest :ignore) :lisp2) +(define-caller-pattern make-condition (form &rest :ignore) :lisp2) +(define-caller-pattern with-simple-restart + ((name form (:star form)) (:star form)) :lisp2) +(define-caller-pattern restart-case + (form + (:star (form form (:star form)))) + :lisp2) +(define-caller-pattern restart-bind + (((:star (name fn &key (:star form)))) + (:star form)) + :lisp2) +(define-caller-pattern with-condition-restarts + (form form + (:star declaration) + (:star form)) + :lisp2) +(define-caller-pattern compute-restarts (&optional form) :lisp2) +(define-caller-pattern restart-name (form) :lisp2) +(define-caller-pattern find-restart (form &optional form) :lisp2) +(define-caller-pattern invoke-restart (form (:star form)) :lisp2) +(define-caller-pattern invoke-restart-interactively (form) :lisp2) +(define-caller-pattern abort (&optional form) :lisp2) +(define-caller-pattern continue (&optional form) :lisp2) +(define-caller-pattern muffle-warning (&optional form) :lisp2) +(define-caller-pattern store-value (form &optional form) :lisp2) +(define-caller-pattern use-value (form &optional form) :lisp2) +(define-caller-pattern invoke-debugger (form) :lisp2) +(define-variable-pattern *debugger-hook* :lisp2) +(define-caller-pattern simple-condition-format-string (form) :lisp2) +(define-caller-pattern simple-condition-format-arguments (form) :lisp2) +(define-caller-pattern type-error-datum (form) :lisp2) +(define-caller-pattern type-error-expected-type (form) :lisp2) +(define-caller-pattern package-error-package (form) :lisp2) +(define-caller-pattern stream-error-stream (form) :lisp2) +(define-caller-pattern file-error-pathname (form) :lisp2) +(define-caller-pattern cell-error-name (form) :lisp2) +(define-caller-pattern arithmetic-error-operation (form) :lisp2) +(define-caller-pattern arithmetic-error-operands (form) :lisp2) + +;;; For ZetaLisp Flavors +(define-caller-pattern send (form fn (:star form)) :flavors) blob - /dev/null blob + aff6808e4a27a933ab58ce1349998e30f30e1a4e (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.dir-locals.el @@ -0,0 +1,9 @@ +((nil + (indent-tabs-mode . nil)) + (makefile-mode + (indent-tabs-mode . t)) + (git-commit-mode + (git-commit-major-mode . git-commit-elisp-text-mode)) + ("CHANGELOG" + (nil (fill-column . 70) + (mode . display-fill-column-indicator)))) blob - /dev/null blob + d5214814fb48d960219726dc736e51b8e47add22 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/ISSUE_TEMPLATES/bug_report.md @@ -0,0 +1,26 @@ +--- +title: +name: 🪳 Bug report +about: Report a defect. Do not use this for support requests and feature suggestions. +--- + +Please explain + (1) what behavior you expected + (2) what behavior you observed + (3) and how we can reproduce the issue. + +You don't have to quote the above lines to do that. + +Please include a backtrace in your report. In most cases doing: + + M-x toggle-debug-on-error RET + +and then going through the steps again should result in a backtrace. + +Also post the output of: + + M-x magit-version RET + +Before reporting a defect please try to reproduce it using an Emacs instance in which only Magit and its dependencies have been loaded. Other packages or your configuration should not be loaded. This makes it easier to determine whether the issue lays with Magit or something else. + +---- now delete this line and everything above ---- blob - /dev/null blob + 2945e3f69b69f883e7f6516c67ac703e83579df8 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/ISSUE_TEMPLATES/config.yml @@ -0,0 +1,20 @@ +blank_issues_enabled: false +contact_links: + - name: "💕 Please support my work on Transient and other Emacs projects" + url: https://github.com/sponsors/tarsius + about: Thanks! Any support helps. These donations from users are my only income. + - name: "💡 Suggest a feature ☛ please open a discussion instead of an issue" + url: https://github.com/magit/transient/discussions/categories/ideas + about: Start a discussion suggesting an improvement or a new feature. + - name: "🆘 Ask the community for support" + url: https://www.reddit.com/r/emacs + about: Please also consider supporting others. + - name: "🆘 Ask the maintainers for support ☛ please open a discussion" + url: https://github.com/magit/transient/discussions/categories/q-a + about: Please keep in mind that our bandwidth is limited. + - name: "ℹ️ Transient FAQ" + url: https://magit.vc/manual/transient/FAQ.html + about: Others might have had the same question before. + - name: "ℹ️ Transient Manual" + url: https://magit.vc/manual/transient/#Top + about: The fine manual may also be of use. blob - /dev/null blob + 2c1a9879ba86f838755ce756122f3e76dbdeecb4 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/workflows/compile.yml @@ -0,0 +1,6 @@ +name: Compile +on: [push, pull_request] +jobs: + compile: + name: Compile + uses: emacscollective/workflows/.github/workflows/compile.yml@main blob - /dev/null blob + 3b02f40e398f5b3523fb013018aa955a900f2416 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/workflows/manual.yml @@ -0,0 +1,12 @@ +name: Manual +on: + push: + branches: main + tags: "v[0-9]+.[0-9]+.[0-9]+" +jobs: + manual: + name: Manual + uses: emacscollective/workflows/.github/workflows/manual.yml@main + secrets: + aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }} blob - /dev/null blob + e941fb95884c5f23cb56849bf2662e74ed481bf9 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/workflows/stats.yml @@ -0,0 +1,13 @@ +name: Statistics +on: + push: + branches: main + schedule: + - cron: '3 13 * * 1' +jobs: + stats: + name: Statistics + uses: emacscollective/workflows/.github/workflows/stats.yml@main + secrets: + aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }} + aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }} blob - /dev/null blob + 01d105e40fa6512d78353f8fef97e261babf5123 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.github/workflows/test.yml @@ -0,0 +1,6 @@ +name: Test +on: [push, pull_request] +jobs: + test: + name: Test + uses: emacscollective/workflows/.github/workflows/test.yml@main blob - /dev/null blob + fafa324ba9e793cee009a4fc0fe7f8bf2518052f (mode 644) --- /dev/null +++ elpa/transient-0.9.4/.orgconfig @@ -0,0 +1,18 @@ +# -*- mode:org -*- +# Copyright (C) 2021-2025 Jonas Bernoulli +# SPDX-License-Identifier: GPL-3.0-or-later +# URL: https://github.com/emacscollective/org-macros +# Visit that to see these macros in a human-readable format. + +#+language: en + +#+options: H:4 num:3 toc:2 compact-itemx:t +#+property: header-args :eval never + +#+macro: year (eval (format-time-string "%Y")) +#+macro: version (eval (if-let ((tag (ignore-errors (car (process-lines "git" "describe" "--exact-match"))))) (concat "version " (substring tag 1)) (or (ignore-errors (car (process-lines "git" "describe"))) (concat "version " (or $1 ""))))) +#+macro: kbd (eval (format "@@texinfo:@kbd{@@%s@@texinfo:}@@" (let (case-fold-search) (replace-regexp-in-string (regexp-opt '("BS" "TAB" "RET" "ESC" "SPC" "DEL" "LFD" "DELETE" "SHIFT" "Ctrl" "Meta" "Alt" "Cmd" "Super" "UP" "LEFT" "RIGHT" "DOWN") 'words) "@@texinfo:@key{@@\\&@@texinfo:}@@" $1 t)))) +#+macro: kbdvar (eval (format "@@texinfo:@kbd{@@%s@@texinfo:}@@" (let (case-fold-search) (replace-regexp-in-string "<\\([a-zA-Z-]+\\)>" "@@texinfo:@var{@@\\1@@texinfo:}@@" (replace-regexp-in-string (regexp-opt '("BS" "TAB" "RET" "ESC" "SPC" "DEL" "LFD" "DELETE" "SHIFT" "Ctrl" "Meta" "Alt" "Cmd" "Super" "UP" "LEFT" "RIGHT" "DOWN") 'words) "@@texinfo:@key{@@\\&@@texinfo:}@@" $1 t) t)))) +#+macro: codevar (eval (format "@@texinfo:@code{@@%s@@texinfo:}@@" (let (case-fold-search) (replace-regexp-in-string "\\([A-Z][A-Z-]+\\)" "@@texinfo:@var{@@\\&@@texinfo:}@@" $1 t)))) +#+macro: var @@texinfo:@var{@@$1@@texinfo:}@@ +#+macro: dfn @@texinfo:@dfn{@@$1@@texinfo:}@@ blob - /dev/null blob + d63c4c81c81d7f721540a688967112d2ad142046 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/CHANGELOG @@ -0,0 +1,1232 @@ +# -*- mode: org -*- +* v0.9.4 2025-08-01 + +- When using coordinates, trying to insert the same suffix into the + same menu twice, caused it to instead be removed the second time. + #400 + +* v0.9.3 2025-07-01 + +- Improved kludge to work around a bug in Emacs, which may cause + a subprocess to be killed, when the user types ~C-g~, expecting + that to quit a transient menu. #388 + +- Fixed an edge-case when trying to put point on the same suffix + after refreshing the menu. e508e658 + +- Removed an unnecessary redraw, which additionally happened too + early, before suffixes were refreshed. #397 + +* v0.9.2 2025-06-09 + +- Fixed a regression in v0.9.0, which made it impossible to change the + level of a suffix, if that was set inline in the prefix definition. + +* v0.9.1 2025-06-03 + +- As an additional safety measure, unconditionally reset ~inhibit-quit~ + when the emergency exit is taken. b326421f + +- Including groups that are still defined as a variable, instead of + using ~transient-define-group~ (added in v0.9.0), failed in some cases + and prevented the menu from being displayed at all. #389 + +* v0.9.0 2025-06-01 + +- Key descriptions (as returned by ~key-description~ and understood by + ~kbd~) are now the only key binding format understood by Transient. + Vectors are no longer supported. c4e0cba6 + +- Vectors are now preferred to identify a suffix or group in a menu by + coordinates. It is still possible, but discouraged, to use a list. + 1933dda9 + +- The internal format used to store menu layouts has been improved. + The old format is still supported and translated on the fly when + encountered. Instead of rely on that translation, users are advised + to recompile dependent packages after updating Transient to this + release. bcc0bf83 + +- Added new macro ~transient-define-group~, which defines one or more + groups of suffixes to be included in multiple menus. Such included + groups are no longer immediately inlined when referenced in a menu + definition, which makes it possible for users to make changes to + included group and have those change affect all menus that include + them. bcc0bf83 + +- Added new macro ~transient-inline-group~, which inlines an included + group into a specific menu. bcc0bf83 + +- Added new, experimental suffix class ~transient-cons-option~, which is + intended for situations where ~transient-args~ should return an alist, + instead of a list of strings (arguments). 81727bac, e8eb3ebd + +- While a transient menu is active, ~inhibit-quit~ is now set to t. + #388 + +* v0.8.8 2025-05-01 + +- Added option ~transient-common-command-prefix~ to allow using a key + other than ~C-x~ as the prefix key used for many commands common to + all transient menus. Because the use of the ~C-x~ prefix for these + commands causes many global bindings to be shadowed even for menus + that allow invoking non-suffix commands, I highly recommend that + users customize this. 7d08039c + +- Added option ~transient-error-on-insert-failure~, defaulting to ~nil~. + I.e., go back to the pre-v0.8.7 behavior by default but let users + opt-in to errors for certain minor issues. #374 + +- Address a conflict with the keyboard used by the Android port. + #376. + +* v0.8.7 2025-04-01 + +- Added new hook ~transient-post-exit-hook~. 55050b60 + +- ~transient-insert-suffix~ and ~transient-append-suffix~ now signal + error if the specified location is invalid. #374 + +Bug fixes: + +- Autoloaded commands were loaded too late in ~transient-init-suffix~, + resulting in the suffix prototype object not being used. 00112c11 + +* v0.8.6 2025-03-15 + +Bug fixes: + +- ~transient-show-summary~ errored for commands that have neither a + summary nor a docstring. 0886651d + +- ~transient-format-description~ errored for ~transient-information~ + and ~transient-information*~ suffixes. #366 + +- ~transient--wrap-command~ failed to load autoloaded commands. + 40308623 + +- ~transient-suffix-object~ errored if a command is bound more than + once and is invoked using the mouse or ~RET~. f69e1286 + +- For some releases ~transient-suffix-object~ errored if it could not + identify a unique suffix, which helped establish that it is in fact + legitimate to use this function as a predicate. No longer error if + there are zero matches, but continue to error if their are multiple + matches that cannot be disambiguated. 4a06aeb0 + +* v0.8.5 2025-03-01 + +- Added new faces ~transient-key-recurse~ and ~transient-key-stack~. + 58e22554 + +Bug fixes: + +- ~transient--setup-recursion~ did not consider the ~recurse~ shorthand. + 32a7e256 + +- The parent group was not always stored in suffix objects. #354 + +- Invoking a suffix of a sub-prefix (which is configured to return to + the outer prefix), did exit instead of returning, if the suffix's + own behavior was not explicitly specified. #352 + +- The color of a suffix that returns to the outer prefix, was wrong + when there isn't actually an outer prefix. e88005d2 + +- When potentially removing other bindings for the same command + while adding a new binding, false-negative avoidance was too heavily + favored over false-positive avoidance. #355 + +- Defining the ~transient-higher-level~ face involves calling + ~face-attributes~ on another face. That call requested the value + for the current frame (which may not exist yet) instead of using + the default. #359 + +- When the transient window is hidden while the minibuffer is used, + then it was not restored if using Helm. #361 + +- Non-suffix command that aren't accessed via a symbol, were not + properly wrapped to ensure post-command cleanup happens even in + case of an error or if the user aborts a minibuffer use, causing + the menu window to get stuck. 08201f06 + +* v0.8.4 2025-02-01 + +- Added new option ~transient-show-docstring-format~. 65cd6cec + +- Unless called with a prefix argument, ~transient-toggle-docstrings~ + now only shows docstrings for the current menu invocation. 13f3f5e0 + +- The ~##~ macro from the ~llama~ package can now be used after keywords + in group specifications (including suffix bindings). 7c650436 + +- Suffix commands can now be advised using the new ~advice~ and ~advice*~ + slots available for suffixes and groups. This feature is still + experimental. #340 + +- ~transient-scope~ can now also match against prefix classes, not just + specific prefix commands. #334 + +- The default level of a suffix command can now be set via its + prototype, using the new function ~transient-set-default-level~. + f6c249c7 + +* v0.8.3 2025-01-03 + +- Added new constant ~transient-version~. 3022f6d5 + +* v0.8.2 2025-01-01 + +- Added support for displaying the transient menu in a dedicated + frame. bf58c0bb + +- When including a group via a variable, the imported value can now be + a top-level group. eebcbe30 + +- The transient window is now fitted to its buffer horizontally as well. + fd9811ea + +- Added new command ~transient-copy-menu-text~. 042f37aa + +- Added new command ~transient-toggle-docstrings~. 52679f98 + +- Added new command ~transient-describe~, which can be bound as many times + as needed to show help for arbitrary things. 5a18a791 + +Bug fixes: + +- The use of ~display-buffer-full-frame~ was prevented too aggressively. + 5353464b + +- Fixed remembering and restoring the old value of the ~no-other-window~ + window parameter. de984302 + +- When a command is bound multiple times and the instances use different + transient behavior, then the behavior (and color) for the last binding + was used for all bindings. fe71a7e7, a99dcda9 + +- Enabling ~transient-force-single-column~ resulted in an error. + 28347e59 + +- ~transient-toggle-common~ used to exit the menu. 98c01b84 + +* v0.8.1 2024-12-08 + +Bug fixes: + +- Interactively setting the level of a transient prefix resulted in + an error. #337. + +* v0.8.0 2024-12-06 + +- While the minibuffer is in use, the menu window is now hidden by + default. The new option ~transient-show-during-minibuffer-read~ not + only controls whether the menu stays visible while the minibuffer + is in use, but also whether it may be resized if necessary. This + new option replaces ~transient-hide-during-minibuffer-read~. #330 + +- When returning to a prefix whose ~refresh-suffixes~ slot is non-nil, + its suffixes are now re-initialized. #327 + +- Added documentation for ~inapt-if*~ slots to manual. 179545a6 + +- ~transient-args~ now takes a prefix command or a list of prefix + commands as argument. + +- ~transient-scope~ now takes a prefix command or a list of prefix + commands and/or a prefix class or list of prefix classes as + arguments. It can still be called without any argument, but that + should only be done in functions that take part in setting up a + menu, not in a suffix command. + +- Added new generic function ~transient-prefix-value~, giving finer + control over how the value returned by ~transient-args~ is determined. + +- Added support for implementing ~transient-init-scope~ methods for + prefix classes. + +- ~transient-setup-buffer-hook~ is now run later to allow overriding + more default settings. + +- The new prefix slots ~display-action~ and ~mode-line-format~, can be + used to override ~transient-display-buffer-action~ and + ~transient-mode-line-format~ for individual prefix menus. #332 + +- Updated the manual considerably. + +Bug fixes: + +- Fixes some menu navigation edge-cases. + +* v0.7.9 2024-11-04 + +Bug fixes: + +- Fixed a recent regression in ~transient-suffix-object~. #325 + +- The height of the transient window was fixed even it used the full + frame height. 5478d4e6 + +* v0.7.8 2024-11-02 + +- Additional potential mistakes in menu definitions are now detected. + bbda5bb6, 8873c300 + +- Added new (and still experimental) ~environment~ prefix slot, which + can be used to, for example, implement a cache to be used while + refreshing the menu. 05c011b8 + +- When navigating through the menu using the keyboard or hovering a + suffix command with the mouse, information about the command is now + shown in the echo area or using a tooltip. #282 + +Bug fixes: + +- When the command that exits a transient uses the minibuffer, + ~transient-current-*~ variables were not immediately reset to + ~nil~. #323 + +- Key sequences with three or more events broke + ~transient-suffix-object~. #324 + +* v0.7.7 2024-10-04 + +Bug fix: + +- Fix a regression introduced by the previous commit, which broke + dynamic prefixes that use a ~:setup-children~ function to prepare + their suffixes. #313 + +* v0.7.6 2024-10-01 + +- ~transient-active-prefix~ now accepts a single prefix symbol, in place + of a list of such symbols. #307 + +- ~other-frame-prefix~ and ~other-window-prefix~ can now be used while a + transient prefix is active. #305 + +- Added new macro ~transient-with-help-window~ for use in ~:show-help~ + functions. #309 + +* v0.7.5 2024-09-01 + +- Updated tooling. + +Bug fixes: + +- ~static-if~ is now used correctly. 0e35673e + +- When an existing window ends up being used to display the transient + buffer, then the previous value of the ~no-other-window~ parameter is + now restored, when the transient is exited. #302 + +- The names assigned to suffixes, which are defined using lambdas in + the prefix definition, are now guaranteed to be unique. #304 + +* v0.7.4 2024-08-05 + +- Added new function ~transient-active-prefix~. + +* v0.7.3 2024-07-13 + +- Refactored code responsible for inserting columns. + +Bug fix: + +- The ~transient-current-*~ variables are intended to only be used by + suffix commands, when they are invoked from a prefix. Previously + they were only cleared when the prefix is ultimately exited, which + meant that they unintentionally were accessible in timers. Now the + values of these variables are nil when used outside their intended + scope. 0e0ece32, f2cb28a5 + +* v0.7.2 2024-06-24 + +- Added support for adding suffixes that activate value presets. #183 + +Bug fix: + +- Restored the ability to individually set infix arguments if the + prefix's ~refresh-suffixes~ slot is non-nil. 8db5f0fd + +* v0.7.1 2024-06-19 + +- Added a workaround for ~emoji.el~ from Emacs 29.1 calling an internal + function using an outdated number of arguments. #288 + +* v0.7.0 2024-06-18 + +- Added new macro ~transient-augment-suffix~, which can be used to + specify the suffix behavior of a command that was previously defined + as a prefix, using ~transient-define-prefix~. 2fd3ea14 + +- Added new function ~transient-scope~, which is just a convenient way + to get the value of the ~scope~ slot of the ~transient-prefix-object~. + 7f6c39c5 + +- Added new hook ~transient-setup-buffer-hook~, which is run early when + setting the transient menu buffer. #283 + +- Added new class ~transient-information*~, a variant of recently added + ~transient-information~ class. 8a80e952 + +- By default our macros that define commands, mark those as for + interactive use only. ~(declare (interactive-only nil))~ can now be + used to overwrite that. fcc60e27 + +- Groups now also accept ~:inapt*~ predicates. 3d395d64 + +- Spaces between columns is reduced from three to two. dd93001e + +- Removed unused ~transient-plist-to-alist~ function. 1251faf0 + +Bug fixes: + +- ~transient--force-fixed-pitch~ was run to late to always succeed. #283 + +- Key binding conflict detection was too strict, taking hypothetical + bindings for inapt commands into account. c356d1bc + +- Key binding conflict detection did not consider bindings in regular + keymaps, such as ~transient-base-map~. 2698d62d + +- ~func-arity~ gets confused when a function is advised, so we had to + add a wrapper function ~transient--func-arity~. 91dd7bb3 + +- Some mistakes, that can be expected to occur when defining suffix and + prefix commands, were not detected. 7e827c31 + +* v0.6.0 2024-03-21 + +- On Emacs 28.1 and later, all infix commands and suffix commands + that are defined inline (i.e., using a lambda when defining a prefix + command), are now hidden from ~execute-extended-command~ (aka ~M-x~) /by + default/. It was already possible to hide these commands, but users + had to opt-in explicitly. After refactoring how these commands are + declared to be unsuitable for ~M-x~, it is now possible to hide them + /without/ also hiding other, unrelated kinds of unsuitable commands. + + I recommend that you instruct ~M-x~ to hide /all/ unsuitable command. + This requires that you customizing ~read-extended-command-predicate~, + because the Emacs authors have decided that this should be an opt-in + feature. + + Note that this has no effect on Emacs releases before 28.1. + +- Added documentation stating that ~:class~ has to be specified when + using ~:setup-children~. beecdc85 + +- Added a new prefix slot ~column-widths~, which can be used to specify + the minimal width of each column in all ~transient-columns~ groups of + that prefix. 92e8952e + +- When assigning a name to a suffix that is defined inline, we no + longer use the suffix description, iff that would result in an + overly long name. 81a108ba + +- Functions used as the value of face slots can now take one + argument, the suffix object. Functions that take zero arguments + are still supported. Additionally, ~transient--pending-suffix~ is + bound around calls to these functions, but it is better to pass + the object as an argument. f582a9bc + +- The new ~definition~ suffix slot can be used to specify a default + function definition that is used if no function body is provided + using ~transient-define-suffix~. 5b334a51 + +- Taught ~transient-suffix-object~ about ~transient--pending-suffix~. + 20a3770d + +Bug fixes: + +- If ~transient-parse-suffix~ and ~transient-parse-suffixes~ are called + with an invalid value for their ~prefix~ argument, they failed to + detect that. 03e752d9 + +- If ~nil~ is encountered inside a group specification, that was + silently ignored. Now an error is signaled. 8c01a1eb + +- ~find-function~ wasn't able to locate the definitions of infix + commands anymore. a30df67b + +- There was no binding for ~ignore-preserving-kill-region~ in + ~transient-predicate-map~. 0fc87002 + +- Invoking a non-symbolic non-suffix command, caused an error. + bd2a5ea0 + +- When a group begins with an included subgroup, that affected what + group class was assumed, in the absence of an explicit specification. + df36bc87 + +- ~transient--suspend-override~ failed to move out of the minibuffer + before refreshing the transient buffer. 833143ba + +- When a suffix command signaled an error during a trivial phase + (which does not involve, e.g., the minibuffer), then the transient + window was not deleted when the debugger was entered. 9d8f361f + +- When a prefix was refreshed, the wrong color was used for suffix + commands that exit the prefix, indicating that would cause a return + to the outer prefix, even though there is none. f51c144a + +- Calling ~transient-infix-read~ with an invalid value, resulted in + a confusing error. Now an appropriate error is used. 3ebb6acf + +- When third-party code or user customization managed to display + another buffer in our dedicated window, then that buffer got + killed when we tried to kill the transient buffer. #271 + +* v0.5.3 2023-12-16 + +- Fixed regression when setting ~:pad-keys~ for a ~transient-columns~ + group. #269 + +* v0.5.2 2023-12-05 + +- Fixed formatting issues in the manual. + +* v0.5.1 2023-12-05 + +- Added a new introduction by JD Smith (@jdtsmith). + +Bug fixes: + +- Faces that use a box are now defined more defensively to protect + against unexpected values and provide reasonable fallback colors. + 413310cd, b8aefce3 + +- Only prepare to return to the parent transient if there actually is + a parent. The only negative effect of failing to do this was that + the suffix was colored wrong, since ~transient--do-return~ falls back + to behave like ~transient--do-exit~. 5f2cfc9f + +* v0.5.0 2023-11-28 + +- Some suffix commands exit the transient from which they were + invoked, while others don't (allowing the user to invoke another + suffix without first having to enter the transient again). + + Until now it wasn't possible to tell which category any given suffix + falls into, at least not by default. Now the key binding of each + suffix is colorized to indicate its transient behavior. Red means + that the suffix exits the transient, and blue means that it does + not. Keys for suffixes that currently cannot be invoked are gray. + + Likewise, the thin line, that is drawn between the transient popup + buffer and the minibuffer, is used to indicate what happens, if you + invoke a command that is not a suffix. Most prefixes do not allow + non-suffixes to be invoked, so this line usually is gray. c8a9ac51 + +- Many faces have also been improved. This involves changing which + built-in faces they inherit from, some explicit changes to their + appearance, and semantic clarifications. Of course your mileage may + vary — it's possible that some face just happened to look right with + your chosen theme, but now it has to be themed to achieve that + again. 47d3f01d 71d16d86 et al. + +- Added a new face, ~transient-delimiter~, which is used for parentheses + around values and the pipe character used to separate possible values + from each other. 567b5d54 + +- Added a new command ~transient-toggle-level-limit~, bound to ~C-x a~, + which temporarily shows all suffix commands a transient has to + offer. This makes it possible to occasionally use more obscure + commands and arguments, without having to always display them. + For more information see [[https://magit.vc/manual/transient/Enabling-and-Disabling-Suffixes.html][Enabling and Disabling Suffixes]]. #243 + +The changes described below, only directly affect package authors and +users who implement their own transients. If that does not describe +you, then all you have to know is that many features were fine-tuned +and otherwise improved, opening up some new use-cases and making some +things easier to implement. This will hopefully lead to improvements +in your favorite transient-using packages in the coming months. + +- It sometimes makes sense to bind multiple keys to the same suffix + command, e.g., because they behave differently based on the suffix + description, or some other slot that can be set per binding. + Previously these bindings shared a visibility level; how this can + be set individually. #153 + +- While functions are run, which format strings to be inserted into the + transient buffer or to determine whether other aspects of a suffix, + that transient buffer no longer is the current buffer. Instead the + buffer in which the prefix and its suffixes operate, is the current + buffer. This affects functions such as ~transient-format-description~ + and those found in predicate slots such as ~if~. In contexts where + the transient buffer is needed but the other buffer happens to be + current, the new macro ~transient-with-shadowed-buffer~ can be used + to temporarily change that. + +- The new suffix slots ~face~ and ~inapt-face~ can be used to specify how + a suffix looks, which in simple cases is more convenient than using + a function as ~description~ and adding the face there. The values of + these slots should be faces or functions that returns a face. The + default for ~inapt-face~ is ~transient-inapt-suffix~, but in some cases + it is undesirable to apply this face to the whole description, so + this can be overridden by setting this slot to ~nil~ for individual + suffixes. The default for ~face~ is ~nil~. c2a75880 8e15a29b 71399d21 + +- Added new variables ~transient--pending-suffix~ and + ~transient--pending-group~, which are bound while a suffix/group is + being inserted. These are mostly intended for internal purposes, + but in some rare complex cases package authors might need them too. + 0717589a 70e8dc80 + +- Sometimes it is useful to display some information in the transient + buffer, which is not associated with a suffix command. The new + class ~transient-information~ can be used for that purpose. Children + that use this class are very similar to regular suffixes, the lack + of a command binding being nearly the only difference. #226 + +- Instead of a list of choices, the value of a suffix's ~choices~ slot + can now be a function that returns such a list. #212 + +- Per-suffix functions that format its description (specified using the + ~description~ slot) can now optionally take one instead of zero argument, + the respective suffix object. 09be367b + +- Added a new command ~transient-echo-arguments~ intended for use in + examples and bug reports, when a prefix must bind some command, but it + does not really matter which. Using this command is less verbose than + having to implement a dummy every time, and it comes with some goodies. + I.e., it reports information about the prefix from which it was invoked. + faa3d09d + +- When a command was defined using ~transient-define-suffix~ and an alias + for that command was created using ~defalias~, then the alias had no + access to the associated suffix object. Now it does, which makes it + possible to bind the same command multiple times in a prefix, and make + it behave differently depending on the symbol-name that was used to + invoke it. f43aee1a + +- The values of a prefix's ~transient-suffix~ and ~transient-non-suffix~ + slots should now be a boolean. The value of the ~transient-suffix~ + slot has to be handled differently for different types of suffixes. + I.e., infix arguments must ignore it, and sub-prefixes must honor + it but to do so they must use a different pre-command. Previously + booleans were not supported and the previously recommended values, + ~transient--do-stay~ and ~transient--do-exit~ are still supported (but + they are "corrected" for sub-prefixes). For the ~transient~ slot the + use of booleans was always allowed and recommended. 8098d175 + +- For sub-prefixes a value of ~t~ for the ~transient-suffix~ slot of the + parent prefix now means that suffixes, which exit the sub-prefix, + return to the parent prefix, instead of exiting that as well. + 784887b7 5ad5b627 + +- In addition to booleans and pre-commands, the values of the + ~transient-suffix~, ~transient-non-suffix~ and ~transient~ slots + may now also be pre-command "shorthands", e.g., use ~leave~ instead + of ~transient--do-leave~ (which in some cases is a good value for + `transient-non-suffix`). 9617b6c7 + +- ~transient--do-replace~ now behaves as documented and implied by its + name. Use the new ~transient--do-stack~ if you want to return to the + outer prefix. 94661e0c + +- Added a new prefix slot ~transient-switch-frame~, which allows + specifying the transient behavior of ~switch-frame~ per prefix and + independently of the transient behavior of other non-suffixes + (specified using the ~transient-non-suffix~ slot). 609dabfd + +- Added a new function ~transient-prefix-object~ to allow package + authors to avoid the following unfortunate complication. + + While a transient is being setup or refreshed (which involves + preparing its suffixes) the variable ~transient--prefix~ can be + used to access the prefix object. Thus this is what has to be + used in suffix methods such as ~transient-format-description~, + and in object-specific functions that are stored in suffix slots + such as ~description~. When a suffix command is invoked (i.e., + in its ~interactive~ form and function body) then the variable + ~transient-current-prefix~ has to be used instead. + + Two distinct variables are needed, because any prefix may itself + be used as a suffix of another prefix, and such sub-prefixes have + to be able to tell themselves apart from the prefix they were + invoked from. Regular suffix commands, which are not prefixes, do + not have to concern themselves with this distinction, so they can + use this function instead. In the context of a plain suffix, it + always returns the value of the appropriate variable. + 37307c1b + +Bug fixes: + +- cc0fa805 transient--post-command: Redisplay after universal argument +- dd970cd4 Compile suffix commands that are defined inside prefix definitions +- b150b48b transient-quit-one: Cancel prefix-arg instead of exiting transient +- 7c08beb8 Revert "transient-{set,save,reset}: Stay transient" +- f8209cc8 transient--maybe-pad-keys: Ignore raw strings +- 0a0ba1aa transient--do-leave: Actually behave as documented +- ed5bd6fd transient-infix-set(argument): Fix disabling incompatible options +- 3a2b936a Fix highlighting infix for which user input is being read +- d834f764 transient-format(around:suffix): Don't attempt to highlight full line +- af6eb310 transient-format: Only highlight infix if minibuffer is used +- b1d1c369 Prevent temporary faces from leaking back into objects +- 307695d2 transient-format-description(around:suffix): Combine faces +- 7f0215c4 transient-format-value(option,value): Use argument faces + +Also contains various documentation updates and a lot of code clean-ups. + +This release drops support for Emacs 25. The last Emacs 25 release +(25.3) was released in 2017; over six years ago. The current Emacs +version is 29.1; that's four major releases since 25.1. + +* v0.4.3 2023-08-25 + +- Added a second implementation of ~transient--wrap-command~, taking + advantage of improvements in Emacs 30. + +* v0.4.2 2023-08-25 + +- Infix commands are only useful when invoked from a transient prefix + command and ~execute-extended-command~ should not offer them as + completion candidates. In the past we used a weird kludge to + accomplish that, but now we rely on ~read-extended-command-predicate~. + That allowed the removal of some complications and made it possible + to fix a bug in ~transient--wrap-command~. + + To hide infix commands, users now have to update to Emacs 28, or + later, and customize ~read-extended-command-predicate~. + + #+begin_src emacs-lisp + (setq read-extended-command-predicate + 'command-completion-default-include-p) + #+end_src + +- Due to changes in Emacs 29.1, pretty-printing isn't consistent + across Emacs releases anymore by default, which is unfortunate + in our case because we use it to write to files that are likely + to be checked into version control. We now force the use of the + old style across releases. + +* v0.4.1 2023-06-02 + +Bug fixes: + +- 070d47b0 Support searches that end right after suffix +- ab831828 transient--insert-group(columns): Drop separator before first column +- 62edeffd #247 Fix bug using :incompatible using suffixes before infixes +- 6efa9fad transient-predicate-map: Bind univeral-argument-more + +* v0.4.0 2023-05-10 + +- Transient has to update state after every suffix command. If that + fails for some reason, then Emacs ends up in an badly broken state. + It was rare, but in the worst case scenario, that meant that Emacs + refused to call any more commands and had to be killed. + + Naturally ~post-command-hook~ is the first choice to run something + after commands, but unfortunately that hook is not guaranteed to run + only once, and worse it is not guaranteed run /after/ the command. + Working around this limitation made an essential part of Transient + much more complex and fragile. As new edge-cases were discovered, + new and increasingly desperate heuristics had to be added, until I + finally decided that relying solely on hooks was just not feasible. + + Now ~pre-command-hook~ is used to advice ~this-command~, to add an + around advice, which ensures that the state update takes place, even + when ~post-command-hook~ is run prematurely. The advice wraps both + the function body and the interactive spec with ~unwind-protect~, so + we can finally be sure that the state change is always performed, + and that the advice is removed again. + + It has been an interesting journey, and I have documented it in long + commit messages. If you are interested in the details, see 7b8a7d71 + (which still tries to avoid using any advice), 51c68c87, 52cac9c0, + bug#61179 and bug#61176. + +- The ~transient-define-prefix~ now expands to code instead of data, + meaning that lambda expressions are finally properly evaluated and + byte-compiled. ea851f3b e88f51d6 277e5f2d a1774182 + +- Popup navigation is no longer considered a second-class feature and + is enabled by default. Some transients allow arbitrary non-suffixes + to be invoked, so some key bindings, which were previously used for + popup navigation, had to be removed, to avoid conflicts. 98d50202 ff + +- Each prefix and suffix can now have its own help function. This is + configured using the new ~show-help~ slot. ea5ac99f + +- The ~transient-options~ class now supports two types of options that + can have multiple values: repeated option-value pairs and a final + option that takes all remaining arguments as value. #154 + +- Added support for the use of non-proportional text in the transient + popup. 7f5520b3 + +- Imenu was taught about Transient's definition macros. #178 + +- It is now possible to return to the parent prefix from a sub-prefix. + e90f7a16 + +- Boolean values of the ~transient~ slot of sub-prefixes are now + interpreted correctly. 4a36b1d9 + +- Added new option ~transient-hide-during-minibuffer-read~. 5762bd9a + +- Added new option ~transient-align-variable-pitch~. cda6a120 + +- Added new command ~transient-reset~, which clears the set and saved + value of the active transient. 51585b8d + +- When using Emacs 28, ~execute-extended-command~ can be told to ignore + transient infix commands. Even when using that Emacs version, that + command does not ignore any commands by default, but this behavior + can be easily be enabled using: + + (setq read-extended-command-predicate + 'command-completion-default-include-p) + + Infix arguments are implemented as commands, so they by default show + up as completion candidates of ~execute-extended-command~, which is + useless because they are only intended to be invoked from transient + prefix commands. Enable this feature to prevent that. + +- Added new command ~transient-toggle-debug~. b466cd9a + +- Depend on the Compat package, allowing me to use convenient features + that were added to Emacs over the last few years, without having to + wait another few years until everybody has updated to a reasonably + recent Emacs release. 5ae3c401 + +- Added basic support for suffixes that span multiple lines (multi-row + cells). #193 + +- Infix arguments can now be invoked following a prefix argument. To + use a negative prefix argument use "C--". "-" cannot be used anymore + because it conflicts with the most common prefix key used for infix + arguments. ed2febd0 + +- Removed obsolete aliases for functions deprecated in v0.3.0. #192 + +- Duplicated suffix commands are now disambiguated, making it possible + to bind a command multiple times as a suffix of a transient command, + but still have it do different things depending on what binding is + used, based on the value of some slot of the corresponding suffix + object, similar to how ~self-insert-command~ inserts the pressed key. + f27c840a + +- ~recursive-edit~ and ~top-level~ can now be used while a transient is + active. fcdeadc1 5a1b2bac + +- Switched to Emacs 29's new keymap functions, which are also supported + in newer releases, thanks to the Compat package. 87f70af5 5a966aa8 + +Bug fixes: + +- 938b0591 #173 transient--show: Set point after displaying window again +- 202271f7 Resurrect transient-files class +- c26cbac5 #181 transient-{init,set}-value: Use case-sensitive matching +- 28491e1f Properly deal with stealth undefined command +- 143a1393 transient-infix-read: Always enable-recursive-minibuffers +- 76b77e01 magit--{pre,post}-command: Add emergency exits +- 09b436fa transient--debug: Ignore error in transient--suffix-symbol +- f2e0dfcc transient--get-predicate-for: Ignore error in transient--suffix-symbol +- bf29731a transient--post-command: Don't pop and push equal redisplay maps +- 3c78b10f transient--redisplay: Don't redisplay during mouse-drag-region +- 714e3482 No longer always suspend when handle-switch-frame is called +- ecb815bc transient--abort-commands: Add keyboard-escape-quit +- 8b1f8dcc transient--minibuffer-depth: Must always be a number +- 686b7ebc Fix handling of sub-prefix command that use the minibuffer +- a19faa1c Return to outer prefix when minibuffer is aborted for sub-prefix +- 4477555b transient--post-exit: Deal with unbound transient slot properly +- 0f39af0e #188 transient-format-description: Use cl-call-next-method +- 1fd1cf51 When highlighting suffixes not normally displayed consider group level +- 7c771c94 Do not let-bind overriding-terminal-local-map to nil +- 31d355b5 transient-set-level: Refresh shown levels after setting one +- bb056e71 Invoke suffix commands directly when a button is pushed +- 270eff1c Fix redisplay when popup navigation is enabled +- 81b2b912 Use this-original-command again +- d4fb853d #198 transient--show: Also hide the header-line +- 7467a79c transient--suspend-override: Cancel display timer +- 5686a792 transient--suspend-override: Cancel prefix key display +- 1c84d7ad Remap kp-subtract, kp-equal and kp-add +- 5302db18 Once popup is showing keep doing so until full exit +- cc887ebe transient--delay-post-command: Fix execute-extended-command handling +- 3b267425 transient--fit-window-to-buffer: Use correct package prefix +- 9d4fabc3 #208 transient--describe-function: Handle renamed help buffer +- 555792f7 #209 Fix setting level of anonymous infixes +- 0a3b22f1 #215 transient--delay-post-command: Account for events returned as vector +- ad953cc3 #204 transient--insert-group: Add fallback for failed alignment calculation +- 5337e5eb #230 transient-define-{*}: Error if ARGLIST is missing +- d800ce01 Use equal to compare with empty vector +- 3657117b #234 transient--parse-suffix: Detect when mandatory command is missing +- f88cbbc5 #234 transient--parse-suffix: Differentiate command and desc lambda +- 0204a243 #234 transient--parse-suffix: Define suffix aliases at load-time +- 0ae0de43 #241 transient--invalid: Add special-case for anonymous inapt commands +- af7fe42b #244 transient--parse-suffix: Don't try to evaluate closures again +- 6ff5c51f transient-isearch-abort: Fix partial match case + +Also contains various documentation updates, code clean-ups and +build improvements. + +* v0.3.7 2021-10-25 + +- Added an additional safety hatch to prevent Emacs from entering an + inconsistent state when an unexpected error occurs. 99e48369 + +- Added support for implementing section movement commands in + third-party packages. This was requested by the maintainer of + Emacspeak. Because they would be of very limited use to sighted + users no such commands are added to Transient itself. 769219b5 + +- ~transient-read-number-{N0,N+,N}~ now support infix arguments that + have three different states: disabled, enabled without an empty + value, and enabled with a non-empty value. 626d105e + +- If a command is called as a suffix of itself, then the help command + shows the function definition instead of the man-page as it usually + does for prefixes. e17e2b2f + +- Give users more control over how the transient buffer is displayed. + Various aspects that were previously hardcoded can now be changed + using the ~transient-display-buffer-action~ option. 7c677737 + +- Added support for adding suffixes that might be neither defined nor + autoloaded when the prefix is invoked. This usually results in an + error and while it is now possible to override that using an extra + step, it is still discouraged. 6842305e + +Bug fixes: + +- 1e740608 transient-map: Bind C-u to universal-argument +- e9048100 Explicitly call transient--pre-command in button action +- be119ee4 Export variables for transient non-infix suffixes +- b526b9c7 transient-infix-set: Consider all incompatibility rules +- 7126d6aa Fix hydra-inspired colors +- 0c2255a2 transient-get-value: Add an emergency exit + +Also contains various documentation updates and code clean-ups. + +* v0.3.6 2021-07-01 + +- Added new option ~transient-force-single-column~, which may be useful + for low vision. #122 + +- Added new option ~transient-highlight-higher-levels~, which is + intended for package authors. 90a05622 + +* v0.3.5 2021-06-16 + +- Added a kludge to work around some unexpected Emacs behavior. + ef921d30 + +- When showing help for a suffix that is also a subprefix, then also + consider the manpage that is set for the prefix, if any. a9bdd013 + +* v0.3.4 2021-05-25 + +- Very minor changes. + +* v0.3.3 2021-05-24 + +- Added SPDX-License-Identifier library header. 7d3d8d79 + +* v0.3.2 2021-04-20 + +- Fixed an error message. c145229a + +* v0.3.1 2021-04-19 + +- Changed ~transient-prefix~'s ~suffix-description~ slot to be initially + unbound, as was always intended. c28b8a4 + +- Added new functions ~transient-read-file~ and + ~transient-read-existing-file~. a3b44224 + +* v0.3.0 2021-02-21 + +- Added a temporary kludge to prevent a transient from being invoked + while the minibuffer is active. A future release will enable + this again, once we are sure that cannot cause Emacs to enter an + inconsistent state, that causes most events to be ignored. #112 + +- Improved the backtrace that is shown when a fatal error occurred in a + critical context. This involved some back and forth. See commits + mentioning the "emergency exit". + +- Added support for defining a per-prefix fallback suffix description + function, which is used for suffixes that do not explicitly provide + a description. The new ~suffix-description~ slot is used to specify + that function. The new ~transient-command-summary-or-name~ function + is useful, not just as an example. 8b22b52b + +- Added ~transient-arg-value~, which can be used to extract the values + of individual arguments in the output of ~transient-args~. d76f73f8 + +- Added support for using variables in group and suffix definitions + of a prefix. Such indirect specifications are resolved when the + transient prefix is being defined. #101 + +- No longer bind ~M-~ to any common suffix commands; freeing this + namespace for a variety of uses in individual transient. A few + existing bindings had to be changed because of this. 990eb0a2 + +- Added ~transient-suffixes~ function, which is useful when + ~transient-args~ is not sufficient because one needs the suffix + objects, not just their values. #98 + +- Added ~init-value~ slot for infix and prefix objects. If this value + bound then it is called with the object as only argument instead of + the primary ~transient-init-value~ method of the object class. #96, + 3284f6a0 + +- Added ~unsavable~ slot for infix objects. If this is non-nil, then + the value of the infix is removed from the prefix value before + saving, setting and adding to history. #96 + +- Added support for right padding the keys of all suffixes in a group. + This is controlled using the new ~pad-keys~ slot of group objects. + 7502390b, 293a437d + +- Added support for delaying setup of the suffixes of a prefix until + that is invoked. Also added support for using unnamed functions as + suffix commands. Taken together these changes make it possible to + dynamically create the list of suffixed. See the ~notmuch-transient~ + package for two examples: ~notmuch-search-transient~ and + ~notmuch-tag-transient~. f2252d53, a3e53633 + +- Added the infix class ~transient-lisp-variable~. 2d8ceff4 + +- Added ~transient-infix-read~, which allows arbitrary commands to read + a value the same way as would the infix command that is provided as + an argument to this function. 73694be4 + +- Added support for coloring suffixes in a Hydra-like fashion. + To enable this, customize option ~transient-semantic-coloring~. + 248862c5 + +- Added support for disabling and dimming suffix commands that are + currently not suitable, instead of completely hiding them. #80 + +- Autoload functions that serve a purpose similar to that of + ~define-key~. #85 + +- Consistently use ~transient-~ as the prefix of all symbols. + The old names remain available as obsolete aliases. dd0c44cb + +- Added support for scrolling the transient popup buffer using the + scroll bar. #84 + +- Various bug fixes. + 48238bf5 Allow invoking arbitrary prefixes as non-suffixes + d85eb790 transient-read-directory: Pass read value through file-local-name + f086cb62 transient--insert-suffix: Allow same key with different predicates + d555d260 transient-format-description(lisp-variable): Return string + 0d79ccfa transient--parse-suffix: Don't fallback to read-string for options + f88dbc43 transient-suffix-object: Support all suffixes + b343e2a3 transient-infix-read: Fix ivy specific kludge + 55bad195 transient--pp-to-file: Bugfix + c1df3b21 Ensure we use symbols in a few more places + 769fa438 transient-set-level: Fix edge-case + 88d935c7 transient-display-buffer-action: inhibit-same-window by default + +* v0.2.0 2020-02-26 + +- ~transient-args~ must now be called with a transient prefix command + as argument. It is now the only argument and its value must be a + symbol now, an object is no longer supported. When this command + does not match ~current-transient-command~, then this function now + returns the set, saved or default value. 0312b93, 7d0db28, + d33fe5a, a6ce195 + +- No longer use the last history element as initial minibuffer input + by default. Added new option ~transient-read-with-initial-input~ to + allow users to restore the old default. dcf7a4d, 5decc6e + +- The set and saved values were not always used. #68 + +- Added support for inserting and removing groups. #36 + +- Added support for specifying where to insert elements and groups + using coordinates. #26 + +- Added support for moving the cursor inside the transient popup + buffer using the arrow keys or Isearch, and for invoke suffix + commands using RET or mouse clicks. Unlike Magit-Popup, Transient + doesn't make the transient popup buffer the current buffer. This + is important when invoking suffix commands that take the current + position into account, but it has the drawback that we do not get + these features for free. Because I also consider them unnecessary + I did not implement them initially. Turns out quite a few users + strongly disagree. Set ~transient-enable-popup-navigation~ to ~t~ to + enable these features. #42 + +- Explicitly support Edebug. Previously when Edebug was triggered + while a transient was active, then Emacs entered an unrecoverable + state. #19 + +- No longer attempt to display a thin line in termcap frames. 0a96a57 + +- Work around some Ivy bugs/incompatibilities. af243d5, fed7ab1 + +- The new option ~transient-force-fixed-pitch~ allows users to use a + monospaced font in transient's popup buffer even if they use a + proportional font for the rest of Emacs. #25, #67 + +- Adapted to backward incompatible changes in Emacs 27 that prevented + faces from extending to the edge of the window as expected. c1ae1ee + +- No longer depend on dash (or any other third-party package). #66 + +- When a transient has conflicting key bindings and Transient is + configure to warn about that, then Emacs entered an unrecoverable + state instead. 75de1f0 + +- ~transient-format-value~ now supports options with multiple values. + #65 + +- Removing a suffix based on its position was broken. 41cbf49 + +- In our popup buffers disable the tab feature that Emacs 27 + introduces. #62 + +- Inserting a new suffix next to another ended up replacing the latter + instead if its key binding was defined in the suffix object. #58 + +- ~transient-undefined~ learned to make some noise. #57 + +- Fix replacing a suffix with another suffix bound to the same key. + 5a360bb, 4ce1868 + +- Characters are no longer allowed as pseudo suffixes. To insert a + an empty cell into a table use the empty string instead. 71687ba + +- Added new variable ~transient--buffer-name~. #45 + +- Some misconfiguration that affects how the transient popup buffer + is displayed could lead to Emacs entering an unrecoverable state. + #34, #44 + +- The echo area is now cleared when the transient popup buffer is + shown. afdf1f0 + +- If ~transient-show-popup~ is 0 or a negative number, then not even + a one-line summary is shown initially. #41 + +- Added new function ~transient-read-directory~. a87cb2c + +- ~define-transient-command~ now supports specifying the level of a + suffix using the ~:level~ keyword argument. 6506cfd + +- The mode-related suffix predicates now also support a list of modes + as argument in addition to a single mode as before. 1c6afb8 + +- The new ~incompatible~ slot of prefix objects makes it possible to + specify which arguments should be autoatically disabled when the + user enables certain other arguments. 544b3bb + +- ~transient--history-push~ is now defined as generic function. 47b7975 + +- The a new ~history-key~ slot and ~transient--history-key~ generic + function for prefix objects. 3668aeb, e627d45 + +- Disallow setting the level of essential suffixes that are shared + between all transients. #29 + +- The active infix is now highlight while reading its value from the + user. #30 + +- The commands ~transient-set~ and ~transient-save~ can now be configured + to exit the transient, though by default they still don't. a47ae94 + +- Always respect the ~transient~ slot of a suffix, even if that suffix + has a binding in ~transient-predicate-map~. 919fc66 + +- Added new generic functions ~transient-set-value~ and + ~transient-save-value~ intended for prefix commands. ebe9d9d + +- It is no longer possible to set a prefix level to 0, which is an + invalid value. #28 + +- All transient prefix and suffix commands are now automatically + declared to be for interactive use only. a6295fa + +- Infix arguments are no longer added to ~command-history~ because + these entries were both useless and extremely noisy. #23 + +- ~digit-argument~ no longer exits the transient. 5f0ec7d + +- A new keymap, ~transient-base-map~ was added to make it easier to + change key bindings that are shared between all transients. This + new keymap is used as the parent of all the other keymaps that are + shared between all transients. + +- Added new commands ~transient-scroll-up~ and ~transient-scroll-down~, + which scroll the transient window. ~C-v~ and ~M-v~ (and ~~ and + ~~) are bound to these commands. These keys were chosen they + are bound to scrolling commands in the global map too. This made + it necessary to find a new binding for ~transient-show~, which ~C-t~ is + bound to now. #17 + +- The new option ~transient-mode-line-format~ allows users to use + a mode-line for the transient popup buffer instead of just a + thin line that separates it from the echo area. When using a + non-standard value for ~transient-display-buffer-action~ it may + be necessary to do that. #17 + +- The new option ~transient-display-buffer-action~ allows users to + specify how a window is selected to display the transient popup + buffer. The ~lv~ library is no longer used. #17 + +- The window that was selected before the transient window was shown + is no longer re-selected before calling a suffix that exits the + transient. If a suffix changes the selected window unintentionally, + then that is a bug. This makes it possible to intentionally change + the window layout using transients. + +- An infix is a special kind of suffix. Depending on context + "suffixes" means "suffixes (including infixes)" or "non-infix + suffixes". This is now mention in a few places where users might + otherwise get confused. + +- Stopped claiming that the transient is shown in the "echo area", + because technically that is not correct. Instead talk about the + "popup buffer". + +- Fixed handling of suffix commands that are undefined at the time the + prefix is invoked. This is still an error, but the error message + now explains what is wrong. a729bbb + +- Fixed saving values/history/levels, making sure that the printed + expression is never abbreviated. #15 + +- Fixed jumping to the correct place in a manpage when showing the + documentation for an infix argument. c4bf4af + +- Bound ~ESC ESC ESC~ to ~transient-quit-all~ because the convention is + that it should be possible to exit any temporary state using this + binding. #12 + +- Fixed referencing suffix bindings by their key when the key binding + is defined in the suffix object instead of in the suffix spec. + e4ffb97 + +- Remove trailing whitespace from popup text for the benefit of users + who have set enabled ~show-trailing-whitespace~ globally. 0758efa + +- Fixed showing available bindings on a single line instead of using + the usual popup buffer. 2f011c9, 99d3bf6 + +- Added a line between the ~lv~ window and the echo area. ca18bb6 + +- Fixed adding a new suffix at the end of a group and removing a + group's last suffix. #20, #6 + +- No longer use ~cl-typep~, which appears to have a bug on Emacs 25. + 9183fe1 + +- Fixed ~lisp~ make target. 170a3fd + +- Fixed reading a number as the value of an infix. 8219c0b + +- Various bug fixes to + ~transient--goto-argument-description~ (4f80a89), + ~transient-show-help~ (ccac95e), + ~transient-infix-read~ (7bf9759). + +* v0.1.0 2019-01-14 + +- First release. blob - /dev/null blob + f288702d2fa16d3cdf0035b15a9fcbc552cd88e7 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program 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 3 of the License, or + (at your option) any later version. + + This program 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 this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. blob - /dev/null blob + 5770a54e71a83c2cac670e7641f04e19758adb29 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/README-elpa @@ -0,0 +1,75 @@ +1 Transient command menus +═════════════════════════ + + Transient is the library used to implement the keyboard-driven “menus” + in [Magit]. It is distributed as a separate package, so that it can + be used to implement similar menus in [other packages]. + + +[Magit] + +[other packages] + +1.1 Some things that Transient can do +───────────────────────────────────── + + • Display current state of arguments + • Display and manage lifecycle of modal bindings + • Contextual user interface + • Flow control for wizard-like composition of interactive forms + • History & persistence + • Rendering arguments for controlling CLI programs + + +1.2 Complexity in CLI programs +────────────────────────────── + + Complexity tends to grow with time. How do you manage the complexity + of commands? Consider the humble shell command `ls'. It now has over + /fifty/ command line options. Some of these are boolean flags (`ls + -l'). Some take arguments (`ls --sort=s'). Some have no effect + unless paired with other flags (`ls -lh'). Some are mutually + exclusive. Some shell commands even have so many options that they + introduce /subcommands/ (`git branch', `git commit'), each with their + own rich set of options (`git branch -f'). + + +1.3 Using Transient for composing interactive commands +────────────────────────────────────────────────────── + + What about Emacs commands used interactively? How do these handle + options? One solution is to make many versions of the same command, + so you don't need to! Consider: `delete-other-windows' vs. + `delete-other-windows-vertically' (among many similar examples). + + Some Emacs commands will simply prompt you for the next "argument" + (`M-x switch-to-buffer'). Another common solution is to use prefix + arguments which usually start with `C-u'. Sometimes these are + sensibly numerical in nature (`C-u 4 M-x forward-paragraph' to move + forward 4 paragraphs). But sometimes they function instead as boolean + "switches" (`C-u C-SPACE' to jump to the last mark instead of just + setting it, `C-u C-u C-SPACE' to unconditionally set the mark). Since + there aren't many standards for the use of prefix options, you have to + read the command's documentation to find out what the possibilities + are. + + But when an Emacs command grows to have a truly large set of options + and arguments, with dependencies between them, lots of option values, + etc., these simple approaches just don't scale. Transient is designed + to solve this issue. Think of it as the humble prefix argument `C-u', + /raised to the power of 10/. Like `C-u', it is key driven. Like the + shell, it supports boolean "flag" options, options that take + arguments, and even "sub-commands", with their own options. But + instead of searching through a man page or command documentation, + well-designed transients /guide/ their users to the relevant set of + options (and even their possible values!) directly, taking into + account any important pre-existing Emacs settings. And while for + shell commands like `ls', there is only one way to "execute" (hit + `Return'!), transients can "execute" using multiple different keys + tied to one of many self-documenting /actions/ (imagine having 5 + different colored return keys on your keyboard!). Transients make + navigating and setting large, complex groups of command options and + arguments easy. Fun even. Once you've tried it, it's hard to go back + to the `C-u what can I do here again?' way. + + blob - /dev/null blob + 92bcaa6f0234399f622a6f572457583353307259 (mode 644) --- /dev/null +++ elpa/transient-0.9.4/README.org @@ -0,0 +1,71 @@ +* Transient command menus + +Transient is the library used to implement the keyboard-driven “menus” +in [[https://github.com/magit/magit/][Magit]]. It is distributed as a separate package, so that it can be +used to implement similar menus in [[https://melpa.org/#/transient][other packages]]. + +** Some things that Transient can do + +- Display current state of arguments +- Display and manage lifecycle of modal bindings +- Contextual user interface +- Flow control for wizard-like composition of interactive forms +- History & persistence +- Rendering arguments for controlling CLI programs + +** Complexity in CLI programs + +Complexity tends to grow with time. How do you manage the complexity +of commands? Consider the humble shell command =ls=. It now has over +/fifty/ command line options. Some of these are boolean flags (=ls -l=). +Some take arguments (=ls --sort=s=). Some have no effect unless paired +with other flags (=ls -lh=). Some are mutually exclusive. Some shell +commands even have so many options that they introduce /subcommands/ +(=git branch=, =git commit=), each with their own rich set of options +(=git branch -f=). + +** Using Transient for composing interactive commands + +What about Emacs commands used interactively? How do these handle +options? One solution is to make many versions of the same command, +so you don't need to! Consider: =delete-other-windows= vs. +=delete-other-windows-vertically= (among many similar examples). + +Some Emacs commands will simply prompt you for the next "argument" +(=M-x switch-to-buffer=). Another common solution is to use prefix +arguments which usually start with =C-u=. Sometimes these are sensibly +numerical in nature (=C-u 4 M-x forward-paragraph= to move forward 4 +paragraphs). But sometimes they function instead as boolean +"switches" (=C-u C-SPACE= to jump to the last mark instead of just +setting it, =C-u C-u C-SPACE= to unconditionally set the mark). Since +there aren't many standards for the use of prefix options, you have to +read the command's documentation to find out what the possibilities +are. + +But when an Emacs command grows to have a truly large set of options +and arguments, with dependencies between them, lots of option values, +etc., these simple approaches just don't scale. Transient is designed +to solve this issue. Think of it as the humble prefix argument =C-u=, +/raised to the power of 10/. Like =C-u=, it is key driven. Like the +shell, it supports boolean "flag" options, options that take +arguments, and even "sub-commands", with their own options. But +instead of searching through a man page or command documentation, +well-designed transients /guide/ their users to the relevant set of +options (and even their possible values!) directly, taking into +account any important pre-existing Emacs settings. And while for +shell commands like =ls=, there is only one way to "execute" (hit +=Return=!), transients can "execute" using multiple different keys tied +to one of many self-documenting /actions/ (imagine having 5 different +colored return keys on your keyboard!). Transients make navigating +and setting large, complex groups of command options and arguments +easy. Fun even. Once you've tried it, it's hard to go back to the +=C-u what can I do here again?= way. + +[[http://readme.emacsair.me/transient.png]] + +#+html:

+#+html: Compile +#+html: Manual +#+html: GNU ELPA +#+html: MELPA Stable +#+html: MELPA blob - /dev/null blob + d4d55406d68453a10f6db6c130ab7c463e5d55ba (mode 644) --- /dev/null +++ elpa/transient-0.9.4/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs misc features +* Transient: (transient). Transient Commands. blob - /dev/null blob + c007dc06966de590c467311a9027d88b038c9ffb (mode 644) --- /dev/null +++ elpa/transient-0.9.4/gpl.texi @@ -0,0 +1,717 @@ +@c The GNU General Public License. +@center Version 3, 29 June 2007 + +@c This file is intended to be included within another document, +@c hence no sectioning command or @node. + +@display +Copyright @copyright{} 2007 Free Software Foundation, Inc. @url{https://fsf.org/} + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. +@end display + +@heading Preamble + +The GNU General Public License is a free, copyleft license for +software and other kinds of works. + +The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom +to share and change all versions of a program---to make sure it remains +free software for all its users. We, the Free Software Foundation, +use the GNU General Public License for most of our software; it +applies also to any other work released this way by its authors. You +can apply it to your programs, too. + +When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + +To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you +have certain responsibilities if you distribute copies of the +software, or if you modify it: responsibilities to respect the freedom +of others. + +For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, +receive or can get the source code. And you must show them these +terms so they know their rights. + +Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + +For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + +Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the +manufacturer can do so. This is fundamentally incompatible with the +aim of protecting users' freedom to change the software. The +systematic pattern of such abuse occurs in the area of products for +individuals to use, which is precisely where it is most unacceptable. +Therefore, we have designed this version of the GPL to prohibit the +practice for those products. If such problems arise substantially in +other domains, we stand ready to extend this provision to those +domains in future versions of the GPL, as needed to protect the +freedom of users. + +Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish +to avoid the special danger that patents applied to a free program +could make it effectively proprietary. To prevent this, the GPL +assures that patents cannot be used to render the program non-free. + +The precise terms and conditions for copying, distribution and +modification follow. + +@heading TERMS AND CONDITIONS + +@enumerate 0 +@item Definitions. + +``This License'' refers to version 3 of the GNU General Public License. + +``Copyright'' also means copyright-like laws that apply to other kinds +of works, such as semiconductor masks. + +``The Program'' refers to any copyrightable work licensed under this +License. Each licensee is addressed as ``you''. ``Licensees'' and +``recipients'' may be individuals or organizations. + +To ``modify'' a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of +an exact copy. The resulting work is called a ``modified version'' of +the earlier work or a work ``based on'' the earlier work. + +A ``covered work'' means either the unmodified Program or a work based +on the Program. + +To ``propagate'' a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + +To ``convey'' a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user +through a computer network, with no transfer of a copy, is not +conveying. + +An interactive user interface displays ``Appropriate Legal Notices'' to +the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + +@item Source Code. + +The ``source code'' for a work means the preferred form of the work for +making modifications to it. ``Object code'' means any non-source form +of a work. + +A ``Standard Interface'' means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + +The ``System Libraries'' of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +``Major Component'', in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + +The ``Corresponding Source'' for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + +The Corresponding Source need not include anything that users can +regenerate automatically from other parts of the Corresponding Source. + +The Corresponding Source for a work in source code form is that same +work. + +@item Basic Permissions. + +All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + +You may make, run and propagate covered works that you do not convey, +without conditions so long as your license otherwise remains in force. +You may convey covered works to others for the sole purpose of having +them make modifications exclusively for you, or provide you with +facilities for running those works, provided that you comply with the +terms of this License in conveying all material for which you do not +control copyright. Those thus making or running the covered works for +you must do so exclusively on your behalf, under your direction and +control, on terms that prohibit them from making any copies of your +copyrighted material outside their relationship with you. + +Conveying under any other circumstances is permitted solely under the +conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + +@item Protecting Users' Legal Rights From Anti-Circumvention Law. + +No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + +When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such +circumvention is effected by exercising rights under this License with +respect to the covered work, and you disclaim any intention to limit +operation or modification of the work as a means of enforcing, against +the work's users, your or third parties' legal rights to forbid +circumvention of technological measures. + +@item Conveying Verbatim Copies. + +You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + +You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + +@item Conveying Modified Source Versions. + +You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these +conditions: + +@enumerate a +@item +The work must carry prominent notices stating that you modified it, +and giving a relevant date. + +@item +The work must carry prominent notices stating that it is released +under this License and any conditions added under section 7. This +requirement modifies the requirement in section 4 to ``keep intact all +notices''. + +@item +You must license the entire work, as a whole, under this License to +anyone who comes into possession of a copy. This License will +therefore apply, along with any applicable section 7 additional terms, +to the whole of the work, and all its parts, regardless of how they +are packaged. This License gives no permission to license the work in +any other way, but it does not invalidate such permission if you have +separately received it. + +@item +If the work has interactive user interfaces, each must display +Appropriate Legal Notices; however, if the Program has interactive +interfaces that do not display Appropriate Legal Notices, your work +need not make them do so. +@end enumerate + +A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +``aggregate'' if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + +@item Conveying Non-Source Forms. + +You may convey a covered work in object code form under the terms of +sections 4 and 5, provided that you also convey the machine-readable +Corresponding Source under the terms of this License, in one of these +ways: + +@enumerate a +@item +Convey the object code in, or embodied in, a physical product +(including a physical distribution medium), accompanied by the +Corresponding Source fixed on a durable physical medium customarily +used for software interchange. + +@item +Convey the object code in, or embodied in, a physical product +(including a physical distribution medium), accompanied by a written +offer, valid for at least three years and valid for as long as you +offer spare parts or customer support for that product model, to give +anyone who possesses the object code either (1) a copy of the +Corresponding Source for all the software in the product that is +covered by this License, on a durable physical medium customarily used +for software interchange, for a price no more than your reasonable +cost of physically performing this conveying of source, or (2) access +to copy the Corresponding Source from a network server at no charge. + +@item +Convey individual copies of the object code with a copy of the written +offer to provide the Corresponding Source. This alternative is +allowed only occasionally and noncommercially, and only if you +received the object code with such an offer, in accord with subsection +6b. + +@item +Convey the object code by offering access from a designated place +(gratis or for a charge), and offer equivalent access to the +Corresponding Source in the same way through the same place at no +further charge. You need not require recipients to copy the +Corresponding Source along with the object code. If the place to copy +the object code is a network server, the Corresponding Source may be +on a different server (operated by you or a third party) that supports +equivalent copying facilities, provided you maintain clear directions +next to the object code saying where to find the Corresponding Source. +Regardless of what server hosts the Corresponding Source, you remain +obligated to ensure that it is available for as long as needed to +satisfy these requirements. + +@item +Convey the object code using peer-to-peer transmission, provided you +inform other peers where the object code and Corresponding Source of +the work are being offered to the general public at no charge under +subsection 6d. + +@end enumerate + +A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + +A ``User Product'' is either (1) a ``consumer product'', which means any +tangible personal property which is normally used for personal, +family, or household purposes, or (2) anything designed or sold for +incorporation into a dwelling. In determining whether a product is a +consumer product, doubtful cases shall be resolved in favor of +coverage. For a particular product received by a particular user, +``normally used'' refers to a typical or common use of that class of +product, regardless of the status of the particular user or of the way +in which the particular user actually uses, or expects or is expected +to use, the product. A product is a consumer product regardless of +whether the product has substantial commercial, industrial or +non-consumer uses, unless such uses represent the only significant +mode of use of the product. + +``Installation Information'' for a User Product means any methods, +procedures, authorization keys, or other information required to +install and execute modified versions of a covered work in that User +Product from a modified version of its Corresponding Source. The +information must suffice to ensure that the continued functioning of +the modified object code is in no case prevented or interfered with +solely because modification has been made. + +If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + +The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or +updates for a work that has been modified or installed by the +recipient, or for the User Product in which it has been modified or +installed. Access to a network may be denied when the modification +itself materially and adversely affects the operation of the network +or violates the rules and protocols for communication across the +network. + +Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + +@item Additional Terms. + +``Additional permissions'' are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + +When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + +Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders +of that material) supplement the terms of this License with terms: + +@enumerate a +@item +Disclaiming warranty or limiting liability differently from the terms +of sections 15 and 16 of this License; or + +@item +Requiring preservation of specified reasonable legal notices or author +attributions in that material or in the Appropriate Legal Notices +displayed by works containing it; or + +@item +Prohibiting misrepresentation of the origin of that material, or +requiring that modified versions of such material be marked in +reasonable ways as different from the original version; or + +@item +Limiting the use for publicity purposes of names of licensors or +authors of the material; or + +@item +Declining to grant rights under trademark law for use of some trade +names, trademarks, or service marks; or + +@item +Requiring indemnification of licensors and authors of that material by +anyone who conveys the material (or modified versions of it) with +contractual assumptions of liability to the recipient, for any +liability that these contractual assumptions directly impose on those +licensors and authors. +@end enumerate + +All other non-permissive additional terms are considered ``further +restrictions'' within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + +If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + +Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; the +above requirements apply either way. + +@item Termination. + +You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + +However, if you cease all violation of this License, then your license +from a particular copyright holder is reinstated (a) provisionally, +unless and until the copyright holder explicitly and finally +terminates your license, and (b) permanently, if the copyright holder +fails to notify you of the violation by some reasonable means prior to +60 days after the cessation. + +Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + +Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + +@item Acceptance Not Required for Having Copies. + +You are not required to accept this License in order to receive or run +a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + +@item Automatic Licensing of Downstream Recipients. + +Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + +An ``entity transaction'' is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + +You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + +@item Patents. + +A ``contributor'' is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's ``contributor version''. + +A contributor's ``essential patent claims'' are all patent claims owned +or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, ``control'' includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + +Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + +In the following three paragraphs, a ``patent license'' is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To ``grant'' such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + +If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. ``Knowingly relying'' means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + +If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + +A patent license is ``discriminatory'' if it does not include within the +scope of its coverage, prohibits the exercise of, or is conditioned on +the non-exercise of one or more of the rights that are specifically +granted under this License. You may not convey a covered work if you +are a party to an arrangement with a third party that is in the +business of distributing software, under which you make payment to the +third party based on the extent of your activity of conveying the +work, and under which the third party grants, to any of the parties +who would receive the covered work from you, a discriminatory patent +license (a) in connection with copies of the covered work conveyed by +you (or copies made from those copies), or (b) primarily for and in +connection with specific products or compilations that contain the +covered work, unless you entered into that arrangement, or that patent +license was granted, prior to 28 March 2007. + +Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + +@item No Surrender of Others' Freedom. + +If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey +a covered work so as to satisfy simultaneously your obligations under +this License and any other pertinent obligations, then as a +consequence you may not convey it at all. For example, if you agree +to terms that obligate you to collect a royalty for further conveying +from those to whom you convey the Program, the only way you could +satisfy both those terms and this License would be to refrain entirely +from conveying the Program. + +@item Use with the GNU Affero General Public License. + +Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + +@item Revised Versions of this License. + +The Free Software Foundation may publish revised and/or new versions +of the GNU General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies that a certain numbered version of the GNU General Public +License ``or any later version'' applies to it, you have the option of +following the terms and conditions either of that numbered version or +of any later version published by the Free Software Foundation. If +the Program does not specify a version number of the GNU General +Public License, you may choose any version ever published by the Free +Software Foundation. + +If the Program specifies that a proxy can decide which future versions +of the GNU General Public License can be used, that proxy's public +statement of acceptance of a version permanently authorizes you to +choose that version for the Program. + +Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + +@item Disclaimer of Warranty. + +THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW@. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM ``AS IS'' WITHOUT +WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE@. THE ENTIRE RISK AS TO THE QUALITY AND +PERFORMANCE OF THE PROGRAM IS WITH YOU@. SHOULD THE PROGRAM PROVE +DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR +CORRECTION. + +@item Limitation of Liability. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR +CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT +NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR +LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM +TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER +PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +@item Interpretation of Sections 15 and 16. + +If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + +@end enumerate + +@heading END OF TERMS AND CONDITIONS + +@heading How to Apply These Terms to Your New Programs + +If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + +To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the ``copyright'' line and a pointer to where the full notice is found. + +@smallexample +@var{one line to give the program's name and a brief idea of what it does.} +Copyright (C) @var{year} @var{name of author} + +This program 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 3 of the License, or (at +your option) any later version. + +This program 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 this program. If not, see @url{https://www.gnu.org/licenses/}. +@end smallexample + +Also add information on how to contact you by electronic and paper mail. + +If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + +@smallexample +@var{program} Copyright (C) @var{year} @var{name of author} +This program comes with ABSOLUTELY NO WARRANTY; for details type @samp{show w}. +This is free software, and you are welcome to redistribute it +under certain conditions; type @samp{show c} for details. +@end smallexample + +The hypothetical commands @samp{show w} and @samp{show c} should show +the appropriate parts of the General Public License. Of course, your +program's commands might be different; for a GUI interface, you would +use an ``about box''. + +You should also get your employer (if you work as a programmer) or school, +if any, to sign a ``copyright disclaimer'' for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +@url{https://www.gnu.org/licenses/}. + +The GNU General Public License does not permit incorporating your +program into proprietary programs. If your program is a subroutine +library, you may consider it more useful t