2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-Scheme-*-
|
|
|
|
|
|
|
|
|
|
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
|
|
|
|
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
|
|
|
|
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
|
|
|
|
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
|
|
|
|
|
|
|
|
|
This file is part of MIT/GNU Scheme.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
|
|
|
|
USA.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Debian changelog mode
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-mode
|
|
|
|
|
"Enter Debian changelog mode."
|
|
|
|
|
()
|
|
|
|
|
(lambda () (set-current-major-mode! (ref-mode-object debian-changelog))))
|
|
|
|
|
|
|
|
|
|
(define-major-mode debian-changelog text "Debian changelog"
|
|
|
|
|
"Major mode for editing Debian-style change logs.
|
|
|
|
|
Runs `debian-changelog-mode-hook' if it exists.
|
|
|
|
|
|
|
|
|
|
Key bindings:
|
|
|
|
|
|
|
|
|
|
\\{debian-changelog}"
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(local-set-variable! fill-prefix " " buffer)
|
|
|
|
|
(local-set-variable! fill-column 74 buffer)
|
|
|
|
|
|
|
|
|
|
;; Let each entry behave as one paragraph:
|
|
|
|
|
(local-set-variable! paragraph-start "\\*" buffer)
|
|
|
|
|
(local-set-variable! paragraph-separate "\\*\\|\\s-*$|\\S-" buffer)
|
|
|
|
|
|
|
|
|
|
;; Let each version behave as one page.
|
|
|
|
|
;; Match null string on the heading line so that the heading line
|
|
|
|
|
;; is grouped with what follows.
|
|
|
|
|
(local-set-variable! page-delimiter "^\\<" buffer)
|
|
|
|
|
(local-set-variable! version-control 'NEVER buffer)
|
|
|
|
|
|
|
|
|
|
(event-distributor/invoke! (ref-variable debian-changelog-mode-hook buffer)
|
|
|
|
|
buffer)))
|
|
|
|
|
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-a) 'debian-changelog-add-entry)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-f)
|
|
|
|
|
'debian-changelog-finalize-last-version)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-c)
|
|
|
|
|
'debian-changelog-finalize-and-save)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-v) 'debian-changelog-add-version)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-d) 'debian-changelog-distribution)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-u) 'debian-changelog-urgency)
|
|
|
|
|
(define-key 'debian-changelog '(#\C-c #\C-e)
|
|
|
|
|
'debian-changelog-unfinalize-last-version)
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-add-version
|
|
|
|
|
"Add a new version section to a debian-style changelog file."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (selected-buffer)))
|
|
|
|
|
(if (not (version-finalized? buffer))
|
|
|
|
|
(error "Previous version not yet finalized."))
|
|
|
|
|
(let* ((finish
|
|
|
|
|
(lambda (package version)
|
|
|
|
|
(let ((m (mark-left-inserting-copy (buffer-start buffer))))
|
|
|
|
|
(insert-string package m)
|
|
|
|
|
(insert-string " (" m)
|
|
|
|
|
(insert-string version m)
|
|
|
|
|
(insert-string ") unstable; urgency=low" m)
|
|
|
|
|
(insert-newlines 2 m)
|
|
|
|
|
(insert-string " * " m)
|
|
|
|
|
(let ((p (mark-right-inserting-copy m)))
|
|
|
|
|
(insert-newlines 2 m)
|
|
|
|
|
(insert-string " --" m)
|
|
|
|
|
(insert-newlines 2 m)
|
|
|
|
|
(mark-temporary! m)
|
|
|
|
|
(mark-temporary! p)
|
|
|
|
|
(set-buffer-point! buffer p)))))
|
|
|
|
|
(prompt
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((package (prompt-for-string "Package name" #f)))
|
|
|
|
|
(finish package
|
|
|
|
|
(prompt-for-string
|
|
|
|
|
"New version (including any revision)"
|
|
|
|
|
#f))))))
|
|
|
|
|
(if (match-title-line buffer #f)
|
|
|
|
|
(let ((package
|
|
|
|
|
(re-match-extract-string title-regexp-index:package-name))
|
|
|
|
|
(version
|
|
|
|
|
(re-match-extract-string title-regexp-index:version)))
|
|
|
|
|
(let ((regs
|
|
|
|
|
(re-string-search-forward "\\([0-9]+\\)$" version)))
|
|
|
|
|
(if regs
|
|
|
|
|
(finish
|
|
|
|
|
package
|
|
|
|
|
(string-append
|
|
|
|
|
(string-head version (re-match-start-index 1 regs))
|
|
|
|
|
(number->string
|
|
|
|
|
(+ (string->number (re-match-extract version regs 1))
|
|
|
|
|
1))))
|
|
|
|
|
(prompt))))
|
|
|
|
|
(prompt))))))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-add-entry
|
|
|
|
|
"Add a new change entry to a debian-style changelog."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (selected-buffer)))
|
|
|
|
|
(if (version-finalized? buffer)
|
|
|
|
|
(error
|
|
|
|
|
(substitute-command-keys
|
|
|
|
|
(string-append
|
|
|
|
|
"Most recent version has been finalized - use "
|
|
|
|
|
"\\[debian-changelog-unfinalize-last-version] or "
|
|
|
|
|
"\\[debian-changelog-add-version]")
|
|
|
|
|
buffer)))
|
|
|
|
|
(let ((m (mark-left-inserting-copy (mark- (trailer-line buffer) 4))))
|
|
|
|
|
(guarantee-newline m)
|
|
|
|
|
(insert-string " * " m)
|
|
|
|
|
(insert-newline m)
|
|
|
|
|
(mark-temporary! m)
|
|
|
|
|
(set-current-point! (mark-1+ m))))))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-distribution
|
|
|
|
|
"Delete the current distribution and prompt for a new one."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(set-title-distribution (selected-buffer)
|
|
|
|
|
(prompt-for-alist-value
|
|
|
|
|
"Select distribution"
|
|
|
|
|
(map (lambda (s) (cons s s))
|
|
|
|
|
'("stable"
|
|
|
|
|
"frozen"
|
2021-04-26 07:57:47 -04:00
|
|
|
|
"unstable"
|
2021-04-26 07:53:20 -04:00
|
|
|
|
"stable frozen unstable"
|
|
|
|
|
"stable unstable frozen"
|
|
|
|
|
"unstable stable frozen"
|
|
|
|
|
"unstable frozen stable"
|
|
|
|
|
"frozen unstable stable"
|
|
|
|
|
"frozen stable unstable"
|
|
|
|
|
"frozen unstable"
|
|
|
|
|
"unstable frozen"
|
|
|
|
|
"stable frozen"
|
|
|
|
|
"frozen stable"
|
|
|
|
|
"stable unstable"
|
|
|
|
|
"unstable stable"))))))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-urgency
|
|
|
|
|
"Delete the current urgency and prompt for a new one."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(set-title-urgency (selected-buffer)
|
|
|
|
|
(prompt-for-alist-value
|
|
|
|
|
"Select urgency"
|
|
|
|
|
(map (lambda (s) (cons s s))
|
|
|
|
|
'("low" "medium" "high" ))))))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-finalize-and-save
|
|
|
|
|
"Finalize, if necessary, and then save a debian-style changelog file."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (selected-buffer)))
|
|
|
|
|
(if (not (version-finalized? buffer))
|
|
|
|
|
(finalize-last-version buffer))
|
|
|
|
|
(save-buffer buffer #f))))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-finalize-last-version
|
|
|
|
|
"Add the `finalization' information (maintainer's name and email
|
|
|
|
|
address and release date)."
|
|
|
|
|
()
|
|
|
|
|
(lambda () (finalize-last-version (selected-buffer))))
|
|
|
|
|
|
|
|
|
|
(define (finalize-last-version buffer)
|
|
|
|
|
(let ((m (mark-left-inserting-copy (trailer-line buffer))))
|
|
|
|
|
(delete-string m (line-end m 0))
|
|
|
|
|
(insert-string " " m)
|
|
|
|
|
(insert-string (or (ref-variable add-log-full-name buffer)
|
|
|
|
|
(mail-full-name buffer))
|
|
|
|
|
m)
|
|
|
|
|
(insert-string " <" m)
|
|
|
|
|
(insert-string (or (ref-variable add-log-mailing-address buffer)
|
|
|
|
|
(user-mail-address buffer))
|
|
|
|
|
m)
|
|
|
|
|
(insert-string "> " m)
|
|
|
|
|
(insert-string (universal-time->string (get-universal-time)) m)
|
|
|
|
|
(mark-temporary! m)))
|
|
|
|
|
|
|
|
|
|
(define-command debian-changelog-unfinalize-last-version
|
|
|
|
|
"Remove the `finalization' information (maintainer's name and email
|
|
|
|
|
address and release date) so that new entries can be made."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (selected-buffer)))
|
|
|
|
|
(if (not (version-finalized? buffer))
|
|
|
|
|
(error "Most recent version is not finalized."))
|
|
|
|
|
(let ((m (trailer-line buffer)))
|
|
|
|
|
(delete-string m (line-end m 0))))))
|
|
|
|
|
|
|
|
|
|
(define (version-finalized? buffer)
|
|
|
|
|
(let ((m (trailer-line buffer)))
|
|
|
|
|
(cond ((re-match-forward
|
|
|
|
|
"[ \t]+\\S [^\n\t]+\\S <[^ \t\n<>]+> \\S [^\t\n]+\\S [ \t]*$"
|
|
|
|
|
m)
|
|
|
|
|
#t)
|
|
|
|
|
((re-match-forward "[ \t]*$" m) #f)
|
|
|
|
|
(else (error "Malformed finalization line.")))))
|
|
|
|
|
|
|
|
|
|
(define (trailer-line buffer)
|
|
|
|
|
(let ((start (buffer-start buffer))
|
|
|
|
|
(end (buffer-end buffer)))
|
|
|
|
|
(let ((m
|
|
|
|
|
(if (re-search-forward "\n\\S " start end)
|
|
|
|
|
(mark1+ (re-match-start 0))
|
|
|
|
|
end)))
|
|
|
|
|
(if (re-search-backward "\n --" m)
|
|
|
|
|
(re-match-end 0)
|
|
|
|
|
(let ((m (mark-left-inserting-copy m)))
|
|
|
|
|
(insert-string " --" m)
|
|
|
|
|
(insert-newlines 2 m)
|
|
|
|
|
(mark-temporary! m)
|
|
|
|
|
(mark- m 2))))))
|
|
|
|
|
|
|
|
|
|
(define (set-title-distribution buffer distribution)
|
|
|
|
|
(set-title-value buffer title-regexp-index:distribution distribution))
|
|
|
|
|
|
|
|
|
|
(define (set-title-urgency buffer urgency)
|
|
|
|
|
(set-title-value buffer title-regexp-index:urgency urgency))
|
|
|
|
|
|
|
|
|
|
(define (set-title-value buffer index value)
|
|
|
|
|
(match-title-line buffer #t)
|
|
|
|
|
(let ((s (mark-left-inserting-copy (re-match-start index)))
|
|
|
|
|
(e (re-match-end index)))
|
|
|
|
|
(delete-string s e)
|
|
|
|
|
(insert-string value s)
|
|
|
|
|
(mark-temporary! s)))
|
|
|
|
|
|
|
|
|
|
(define (match-title-line buffer error?)
|
|
|
|
|
(or (let ((start (buffer-start buffer)))
|
|
|
|
|
(re-match-forward title-regexp start (line-end start 0)))
|
|
|
|
|
(and error? (error "Unable to match title line."))))
|
|
|
|
|
|
|
|
|
|
(define title-regexp
|
|
|
|
|
(let ((package-name "[a-zA-Z0-9+.-]+")
|
|
|
|
|
(version "[a-zA-Z0-9+.:-]+"))
|
|
|
|
|
(string-append "^\\("
|
|
|
|
|
package-name
|
|
|
|
|
"\\) +(\\("
|
|
|
|
|
version
|
|
|
|
|
"\\)) \\( *"
|
|
|
|
|
package-name
|
|
|
|
|
"\\( +"
|
|
|
|
|
package-name
|
|
|
|
|
"\\)* *\\);.*"
|
|
|
|
|
" urgency=\\([a-zA-Z0-9]+\\)")))
|
|
|
|
|
(define title-regexp-index:package-name 1)
|
|
|
|
|
(define title-regexp-index:version 2)
|
|
|
|
|
(define title-regexp-index:distribution 3)
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(define title-regexp-index:urgency 5)
|