From 4ea444198da3467ce74480d25a9f69dbafaccc4f Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Sat, 16 Aug 2014 22:00:34 +0400
Subject: Move 'check-package-freshness' from 'guix package' to 'packages'.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* 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>
---
 guix/scripts/package.scm | 79 ------------------------------------------------
 1 file changed, 79 deletions(-)

(limited to 'guix/scripts')

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 @@ (define-module (guix scripts package)
   #: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 @@ (define-module (guix scripts package)
   #: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 @@ (define matches?
                 (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 @@ (define (upgradeable? name current-version 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.
-- 
cgit v1.2.3