diff options
author | Alex Kost <alezost@gmail.com> | 2014-08-16 22:00:34 +0400 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2014-08-20 10:55:29 +0200 |
commit | 4ea444198da3467ce74480d25a9f69dbafaccc4f (patch) | |
tree | 9e921420099bb9c1cc5c71c22379500d05184b8f /guix/scripts/package.scm | |
parent | b211a66163afd18b282a787e2841a79fbcdb6877 (diff) | |
download | guix-patches-4ea444198da3467ce74480d25a9f69dbafaccc4f.tar guix-patches-4ea444198da3467ce74480d25a9f69dbafaccc4f.tar.gz |
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>
Diffstat (limited to 'guix/scripts/package.scm')
-rw-r--r-- | guix/scripts/package.scm | 79 |
1 files changed, 0 insertions, 79 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 75ab118900..c33fd7b605 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -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. |