[PATCH] package-x.el: package-upload-buffer-internal

[Jambunathan K]

Summary:
-------

1. M-x package-upload-file currently downloads 'archive-contents' from a
   remote location and writes back the updated file to
   package-archive-upload-base. This seems inconsistent to me. The
   attached fix addresses this inconsistency.

2. A new knob 'package-update-news-on-upload' controls the update of
   news and rss feeds.

Note: 

1. package-x.el was manually downloaded from repo.or.cz a few hours
   ago. I don't have (and don't intend to) checkout emacs. Hope the
   patch applies cleanly.
2. My FSF papers (for orgmode) are in postal transit.

Jambunathan K.

Changelog:
---------

2010-10-28  Jambunathan K  <address@hidden>

        * package-x.el (package-update-news-on-upload): New knob. Set it
        to nil if you are not interested in NEWS and RSS feeds.
        (package--archive-contents-from-url): New. Download
        archive-contents from archive-url, parse it and return the val.
        (package--archive-contents-from-file): New. Parse
        'archive-contents' and return the val.
        (package-upload-buffer-internal): Modified. Read archive-contents
        from package-archive-upload-base and not from archive-url. Use
        archive-url only for writing in to rss feeds. This is a departure
        from current behaviour.


--- package-x.el        2010-10-28 00:57:05.875000000 +0530
+++ package-x-modified.el       2010-10-28 01:06:51.078125000 +0530
@@ -40,6 +40,9 @@
 (defvar package-archive-upload-base nil
   "Base location for uploading to package archive.")
 
+(defvar package-update-news-on-upload t
+  "Should package upload also update NEWS and RSS feeds?.")
+
 (defun package--encode (string)
   "Encode a string by replacing some characters with XML entities."
   ;; We need a special case for translating "&" to "&amp;".
@@ -86,6 +89,39 @@
        (unless old-buffer
          (kill-buffer (current-buffer)))))))
 
+(defun package--archive-contents-from-url (&optional archive-url) 
+  "Parse archive-contents file at ARCHIVE-URL.
+
+If ARCHIVE-URL is unspecified the \"gnu\" archive is used."
+  (unless archive-url
+    (or (setq archive-url (cdr (assoc "gnu" package-archives)))
+       (error "No destination URL")))
+
+  (let* ((buffer (url-retrieve-synchronously
+                 (concat archive-url "archive-contents"))))
+    (set-buffer buffer)
+    (package-handle-response)
+    (re-search-forward "^$" nil 'move)
+    (forward-char)
+    (delete-region (point-min) (point))
+    (prog1 (package-read-from-string
+           (buffer-substring-no-properties (point-min) (point-max)))
+          (kill-buffer buffer))))
+
+(defun package--archive-contents-from-file (file)
+  "Parse the given archive-contents file."
+  (if (not (file-exists-p file))
+      ;; no existing archive-contents, possibly a new ELPA repo.
+      (list package-archive-version)
+    (let ((dont-kill (find-buffer-visiting file)))
+      (with-current-buffer (let ((find-file-visit-truename t))
+                            (find-file-noselect file))
+       (prog1
+           (package-read-from-string
+            (buffer-substring-no-properties (point-min) (point-max)))
+         (unless dont-kill
+           (kill-buffer (current-buffer))))))))
+    
 (defun package-maint-add-news-item (title description archive-url)
   "Add a news item to the ELPA web pages.
 TITLE is the title of the news item.
@@ -107,15 +143,17 @@ You need administrative access to ELPA t
 
 (defun package-upload-buffer-internal (pkg-info extension &optional 
archive-url)
   "Upload a package whose contents are in the current buffer.
+By default, package files and archive-contents are uploaded to
+the `default-directory'. Set `package-archive-upload-base' to
+override the default behaviour.
 PKG-INFO is the package info, see `package-buffer-info'.
 EXTENSION is the file extension, a string.  It can be either
 \"el\" or \"tar\".
 
-Optional arg ARCHIVE-URL is the URL of the destination archive.
-If nil, the \"gnu\" archive is used."
-  (unless archive-url
-    (or (setq archive-url (cdr (assoc "gnu" package-archives)))
-       (error "No destination URL")))
+Optional arg ARCHIVE-URL is the URL of the destination archive to
+be embedded in the RSS file. If nil, the \"gnu\" archive is
+used. This arg is effective only when
+`package-update-news-on-upload' is non-nil."
   (save-excursion
     (save-restriction
       (let* ((file-type (cond
@@ -132,20 +170,10 @@ If nil, the \"gnu\" archive is used."
             (commentary (aref pkg-info 4))
             (split-version (version-to-list pkg-version))
             (pkg-buffer (current-buffer))
+            (upload-dir (or package-archive-upload-base default-directory)))
 
-            ;; Download latest archive-contents.
-            (buffer (url-retrieve-synchronously
-                     (concat archive-url "archive-contents"))))
-
-       ;; Parse archive-contents.
-       (set-buffer buffer)
-       (package-handle-response)
-       (re-search-forward "^$" nil 'move)
-       (forward-char)
-       (delete-region (point-min) (point))
-       (let ((contents (package-read-from-string
-                        (buffer-substring-no-properties (point-min)
-                                                        (point-max))))
+       (let ((contents (package--archive-contents-from-file
+                        (concat upload-dir "archive-contents")))
              (new-desc (vector split-version requires desc file-type)))
          (if (> (car contents) package-archive-version)
              (error "Unrecognized archive version %d" (car contents)))
@@ -166,32 +194,35 @@ If nil, the \"gnu\" archive is used."
                (print-length nil))
            (write-region (concat (pp-to-string contents) "\n")
                          nil
-                         (concat package-archive-upload-base
-                                 "archive-contents")))
+                         (concat upload-dir "archive-contents")))
 
          ;; If there is a commentary section, write it.
          (when commentary
            (write-region commentary nil
-                         (concat package-archive-upload-base
+                         (concat upload-dir
                                  (symbol-name pkg-name) "-readme.txt")))
 
          (set-buffer pkg-buffer)
-         (kill-buffer buffer)
          (write-region (point-min) (point-max)
-                       (concat package-archive-upload-base
+                       (concat upload-dir
                                file-name "-" pkg-version
                                "." extension)
                        nil nil nil 'excl)
 
          ;; Write a news entry.
+         (when package-update-news-on-upload
+           (unless archive-url
+             (or (setq archive-url (cdr (assoc "gnu" package-archives)))
+                 (error "No destination URL")))
+           
          (package--update-news (concat file-name "." extension)
-                               pkg-version desc archive-url)
+                                 pkg-version desc archive-url))
 
          ;; special-case "package": write a second copy so that the
          ;; installer can easily find the latest version.
          (if (string= file-name "package")
              (write-region (point-min) (point-max)
-                           (concat package-archive-upload-base
+                           (concat upload-dir
                                    file-name "." extension)
                            nil nil nil 'ask)))))))