guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

Move 'check-package-freshness' from 'guix package' to 'packages'. 

* guix/scripts/package.scm (%sigint-prompt, call-with-sigint-handler)
  (waiting, ftp-open*, check-package-freshness): Move to...
* gnu/packages.scm: ... here.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Alex Kost 2014-08-16 22:00:34 +04:00 committed by Ludovic Courtès
parent b211a66163
commit 4ea444198d
2 changed files with 83 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
gnu/packages.scm
View File

@ -22,6 +22,8 @@
#:use-module (guix packages)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (guix gnu-maintenance)
#:use-module (ice-9 ftw)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
@ -41,7 +43,9 @@
package-direct-dependents
package-transitive-dependents
package-covering-dependents))
package-covering-dependents
check-package-freshness))
;;; Commentary:
;;;
@ -244,3 +248,81 @@ include all of PACKAGES and all packages that depend on PACKAGES."
(lambda (node) (vhash-refq dependency-dag node))
;; Start with the dependents to avoid including PACKAGES in the result.
(package-direct-dependents packages))))
(define %sigint-prompt
;; The prompt to jump to upon SIGINT.
(make-prompt-tag "interruptible"))
(define (call-with-sigint-handler thunk handler)
"Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
number in the context of the continuation of the call to this function, and
return its return value."
(call-with-prompt %sigint-prompt
(lambda ()
(sigaction SIGINT
(lambda (signum)
(sigaction SIGINT SIG_DFL)
(abort-to-prompt %sigint-prompt signum)))
(dynamic-wind
(const #t)
thunk
(cut sigaction SIGINT SIG_DFL)))
(lambda (k signum)
(handler signum))))
(define-syntax-rule (waiting exp fmt rest ...)
"Display the given message while EXP is being evaluated."
(let* ((message (format #f fmt rest ...))
(blank (make-string (string-length message) #\space)))
(display message (current-error-port))
(force-output (current-error-port))
(call-with-sigint-handler
(lambda ()
(dynamic-wind
(const #f)
(lambda () exp)
(lambda ()
;; Clear the line.
(display #\cr (current-error-port))
(display blank (current-error-port))
(display #\cr (current-error-port))
(force-output (current-error-port)))))
(lambda (signum)
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
(define ftp-open*
;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
;; FTP connection for each package, esp. since most of them are to the same
;; server. This has a noticeable impact when doing "guix upgrade -u".
(memoize ftp-open))
(define (check-package-freshness package)
"Check whether PACKAGE has a newer version available upstream, and report
it."
;; TODO: Automatically inject the upstream version when desired.
(catch #t
(lambda ()
(when (false-if-exception (gnu-package? package))
(let ((name (package-name package))
(full-name (package-full-name package)))
(match (waiting (latest-release name
#:ftp-open ftp-open*
#:ftp-close (const #f))
(_ "looking for the latest release of GNU ~a...") name)
((latest-version . _)
(when (version>? latest-version full-name)
(format (current-error-port)
(_ "~a: note: using ~a \
but ~a is available upstream~%")
(location->string (package-location package))
full-name latest-version)))
(_ #t)))))
(lambda (key . args)
;; Silently ignore networking errors rather than preventing
;; installation.
(case key
((getaddrinfo-error ftp-error) #f)
(else (apply throw key args))))))

79
guix/scripts/package.scm
View File

@ -29,7 +29,6 @@
#:use-module (guix config)
#:use-module (guix scripts build)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@ -42,7 +41,6 @@
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (guile-final))
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:use-module (guix gnu-maintenance)
#:export (specification->package+output
guix-package))
@ -215,48 +213,6 @@ RX."
(package-name p2))))
same-location?))
(define %sigint-prompt
;; The prompt to jump to upon SIGINT.
(make-prompt-tag "interruptible"))
(define (call-with-sigint-handler thunk handler)
"Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal
number in the context of the continuation of the call to this function, and
return its return value."
(call-with-prompt %sigint-prompt
(lambda ()
(sigaction SIGINT
(lambda (signum)
(sigaction SIGINT SIG_DFL)
(abort-to-prompt %sigint-prompt signum)))
(dynamic-wind
(const #t)
thunk
(cut sigaction SIGINT SIG_DFL)))
(lambda (k signum)
(handler signum))))
(define-syntax-rule (waiting exp fmt rest ...)
"Display the given message while EXP is being evaluated."
(let* ((message (format #f fmt rest ...))
(blank (make-string (string-length message) #\space)))
(display message (current-error-port))
(force-output (current-error-port))
(call-with-sigint-handler
(lambda ()
(dynamic-wind
(const #f)
(lambda () exp)
(lambda ()
;; Clear the line.
(display #\cr (current-error-port))
(display blank (current-error-port))
(display #\cr (current-error-port))
(force-output (current-error-port)))))
(lambda (signum)
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
(define-syntax-rule (leave-on-EPIPE exp ...)
"Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
with successful exit code. This is useful when writing to the standard output
@ -320,41 +276,6 @@ an output path different than CURRENT-PATH."
(not (string=? current-path candidate-path))))))
(#f #f)))
(define ftp-open*
;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
;; FTP connection for each package, esp. since most of them are to the same
;; server. This has a noticeable impact when doing "guix upgrade -u".
(memoize ftp-open))
(define (check-package-freshness package)
"Check whether PACKAGE has a newer version available upstream, and report
it."
;; TODO: Automatically inject the upstream version when desired.
(catch #t
(lambda ()
(when (false-if-exception (gnu-package? package))
(let ((name (package-name package))
(full-name (package-full-name package)))
(match (waiting (latest-release name
#:ftp-open ftp-open*
#:ftp-close (const #f))
(_ "looking for the latest release of GNU ~a...") name)
((latest-version . _)
(when (version>? latest-version full-name)
(format (current-error-port)
(_ "~a: note: using ~a \
but ~a is available upstream~%")
(location->string (package-location package))
full-name latest-version)))
(_ #t)))))
(lambda (key . args)
;; Silently ignore networking errors rather than preventing
;; installation.
(case key
((getaddrinfo-error ftp-error) #f)
(else (apply throw key args))))))
;;;
;;; Search paths.