[PATCH] Export 'check-package-freshness'

[Alex Kost <alezost@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 389 bytes --]

Ludovic Courtès (2014-08-13 20:03 +0400) wrote:

[...]

> Alex Kost <alezost@gmail.com> skribis:
>
> [...]
>
>> Also I think "guix.el" should check for freshness too, so
>> ‘check-package-freshness’ should probably be exported.
>
> Yes, probably in the (gnu packages) module?

Here is the patch for that.  I'm not sure about the commit message.
Should it be changed?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Move-check-package-freshness-from-guix-package-to-pa.patch --]
[-- Type: text/x-patch, Size: 9089 bytes --]

From a13dbc81b6ca8c16343aaaafd17ec57812f0c24e Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Sat, 16 Aug 2014 22:00:34 +0400
Subject: [PATCH] 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.
---
 gnu/packages.scm         | 84 +++++++++++++++++++++++++++++++++++++++++++++++-
 guix/scripts/package.scm | 79 ---------------------------------------------
 2 files changed, 83 insertions(+), 80 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 77d9d3e..bad7efb 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -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:
 ;;;
@@ -246,3 +250,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))))
+
+\f
+(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))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3bfef4f..239df77 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))
 
@@ -258,48 +256,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
@@ -363,41 +319,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))))))
-
 \f
 ;;;
 ;;; Search paths.
-- 
2.0.3