source: trunk/source/cocoa-ide/ide-self-update.lisp

Last change on this file was 16686, checked in by rme, 4 years ago

Update copyright/license headers in cocoa-ide directory.

File size: 19.4 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;
3;;; Copyright 2008 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package :ccl)
18(require :sequence-utils)
19
20;;; -----------------------------------------------------------------
21;;; IDE automated self-rebuild
22;;; -----------------------------------------------------------------
23;;; normally we run the self-rebuild after an update from the
24;;; source repo. the steps are:
25;;; 1. rename Clozure CL.app to Clozure CL-last.app
26;;;    (check for older versions and rename with a numbering scheme)
27;;; 2. run an external process that starts ccl and evaluates (rebuild-ccl :full t)
28;;; 3. run an external process that starts ccl and evaluates (require :cocoa-application)
29;;; 4. quit the current IDE (with a farewell message to the effect that the IDE has been rebuilt)
30;;; 5. relaunch the IDE (?)
31;;; (for a simple way to quit and relaunch, see http://www.cocoabuilder.com/archive/message/cocoa/2008/3/3/200352)
32
33(defun ide-self-rebuild ()
34  (let* ((ccl-dir (gui::find-ccl-directory))
35         (bundle (probe-file (merge-pathnames "Clozure CL.app" ccl-dir))))
36    (if bundle
37        ;; found the bundle; proceed with rebuilding...
38        (let* ((result-status nil)
39               (lisp (merge-pathnames (standard-kernel-name) ccl-dir)))
40          (gui::with-modal-progress-dialog "Rebuilding" "Rebuilding Clozure CL (please wait)..."
41                                           (run-program lisp `("-e" "(rebuild-ccl :full t)") 
42                                                        ::status-hook (lambda (ep) 
43                                                                        (multiple-value-bind (status status-code) 
44                                                                            (external-process-status ep)
45                                                                          (when (eql status :exited)
46                                                                            (setf result-status status-code))))))
47          (if (zerop result-status)
48              ;; rebuild succeeded; continue...
49              (let* ((old-bundle (merge-pathnames "Clozure CL-last.app" ccl-dir)))
50                ;; if there is already an old bundle, delete it
51                (when (probe-file old-bundle)
52                  (recursive-delete-directory old-bundle))
53                ;; rename the current bundle to the old-bundle
54                (rename-file bundle old-bundle)
55                ;; rebuild the IDE
56                (setf result-status nil)
57                (gui::with-modal-progress-dialog "Rebuilding" "Rebuilding the IDE (please wait)..."
58                                                 (run-program lisp `("-e" "(require :cocoa-application)") 
59                                                              ::status-hook (lambda (ep) 
60                                                                              (multiple-value-bind (status status-code) 
61                                                                                  (external-process-status ep)
62                                                                                (when (eql status :exited)
63                                                                                  (setf result-status status-code))))))
64                (if (zerop result-status)
65                    ;; inform the user that the IDE is rebuilt and we will quit
66                    (progn
67                      (gui::alert-window :title "Rebuilding IDE Succeeded"
68                                 :message (format nil 
69                                                  "Clozure CL is rebuilt; you can start the new IDE after this copy quits."))
70                      (quit))
71                    ;; warn the user that the IDE rebuild failed and we will quit
72                    (progn
73                      (gui::alert-window :title "Rebuilding IDE Failed"
74                                 :message (format nil 
75                                                  "Rebuilding the IDE failed with error code ~A. The previous IDE has been moved to ~A."
76                                                  result-status old-bundle))
77                      (quit))))
78              ;; warn the user that rebuilding failed and exit
79              (gui::alert-window :title "Rebuilding CCL Failed"
80                                 :message (format nil 
81                                                  "Clozure CL exited with error status = ~A"
82                                                  result-status))))
83        ;; else: the bundle doesn't seem to be there
84        (gui::alert-window :title "Rebuilding CCL Failed"
85                        :message (format nil 
86                                         "Can't find the application '~A'."
87                                         bundle)))))
88
89;;; -----------------------------------------------------------------
90;;; svn metadata utils
91;;; -----------------------------------------------------------------
92
93;;; VALIDATE-SVN-DATA-PATHNAME p
94;;; -----------------------------------------------------------------
95;;; returns TRUE if P is really an existing directory that appears to
96;;; contain valid Subversion metadata; NIL otherwise
97
98(defmethod validate-svn-data-pathname ((p pathname))
99  (and (probe-file p)
100       (directoryp p)
101       (string= ".svn" (first (last (pathname-directory p))))
102       ;; if we reached this point, it's an existing directory
103       ;; named ".svn". now, does it have Subversion metadata files
104       ;; in it?
105       (let ((subversion-metafiles '("dir-prop-base" "entries" "format"
106                                     "prop-base/" "props/" "text-base/")))
107         (every (lambda (f) (probe-file (merge-pathnames f p))) 
108                subversion-metafiles))))
109
110(defmethod validate-svn-data-pathname ((p string))
111  (validate-svn-data-pathname (pathname p)))
112
113;;; -----------------------------------------------------------------
114;;; url utils
115;;; -----------------------------------------------------------------
116
117;;; URL-P thing
118;;; -----------------------------------------------------------------
119;;; returns true if THING is a string that appears to contain a URL,
120;;; NIL otherwise
121
122(defmethod url-p (thing)
123  (declare (ignore thing))
124  nil)
125
126(defmethod url-p ((url string))
127  (if (find-matching-subsequence "://" url)
128      t
129      nil))
130
131;;; URL-PROTOCOL url
132;;; -----------------------------------------------------------------
133;;; returns the protocol pprtion of the URL, or NIL if none
134;;; can be identified
135
136(defmethod url-protocol ((url string))
137  (let ((index (find-matching-subsequence "://" url)))
138    (if index
139        (subseq url 0 index)
140        nil)))
141
142;;; URL-HOST url
143;;; -----------------------------------------------------------------
144;;; returns two values:
145;;; 1. the hostname of the URL
146;;; 2. the username portion of the host segment, if any, or NIL
147
148(defmethod url-host ((url string))
149  (let* ((protocol-marker "://")
150         (protocol-marker-index (find-matching-subsequence protocol-marker url)))
151    (if protocol-marker-index
152        (let* ((protocol-end-index (+ protocol-marker-index (length protocol-marker)))
153               (host-end-index (find-matching-subsequence "/" url :start protocol-end-index))
154               (host-segment (subseq url protocol-end-index host-end-index))
155               (username-terminus-index (find-matching-subsequence "@" host-segment))
156               (username (if username-terminus-index
157                             (subseq host-segment 0 username-terminus-index)
158                             nil))
159               (host (if username-terminus-index
160                         (subseq host-segment (1+ username-terminus-index))
161                         host-segment)))
162          (values host username))
163        nil)))
164
165;;; URL-PATH url
166;;; -----------------------------------------------------------------
167;;; returns the pathname portion of a URL, or NIL if none can be identified
168
169(defmethod url-path ((url string))
170  (let* ((protocol-marker "://")
171         (protocol-marker-index (find-matching-subsequence protocol-marker url)))
172    (if protocol-marker-index
173        (let* ((protocol-end-index (+ protocol-marker-index (length protocol-marker)))
174               (host-end-index (find-matching-subsequence "/" url :start protocol-end-index)))
175          (if host-end-index
176              (subseq url host-end-index)
177              nil))
178        nil)))
179
180;;; -----------------------------------------------------------------
181;;; running svn commands
182;;; -----------------------------------------------------------------
183
184(defmethod svn-info ((p string))
185  (let* ((result-status nil)
186         (info (with-output-to-string (out)
187                 (run-program *svn-program* `("info" ,p) 
188                              :output out
189                              :status-hook (lambda (ep) 
190                                             (multiple-value-bind (status status-code) 
191                                                 (external-process-status ep)
192                                               (when (eql status :exited)
193                                                 (setf result-status status-code))))))))
194    (values info result-status)))
195
196(defmethod svn-info ((p pathname))
197  (svn-info (namestring p)))
198
199(defmethod svn-update ((p string))
200  (let ((result-status nil))
201    (run-program *svn-program* `("update" ,p) 
202               :status-hook (lambda (ep) 
203                              (multiple-value-bind (status status-code) 
204                                  (external-process-status ep)
205                                (when (eql status :exited)
206                                  (setf result-status status-code)))))
207    result-status))
208
209(defmethod svn-update ((p pathname))
210  (svn-update (namestring p)))
211
212;;; -----------------------------------------------------------------
213;;; parsing info
214;;; -----------------------------------------------------------------
215
216(defmethod split-svn-info-line ((line string))
217  (let* ((split-sequence ": ")
218         (split-index (find-matching-subsequence split-sequence line :test #'char=))
219         (prefix (subseq line 0 split-index))
220         (suffix (subseq line (if split-index
221                                  (+ split-index (length split-sequence))
222                                  (length line)))))
223    (list prefix suffix)))
224
225(defmethod parse-svn-info ((info-string string))
226  (let ((info-lines (split-lines info-string)))
227    (mapcar #'split-svn-info-line info-lines)))
228
229(defun svn-revision ()
230  (svn-info-component "Revision:"))
231
232(defun check-svn ()
233  (multiple-value-bind (status exit-code)
234      (external-process-status
235       (run-program *svn-program* '("--version" "--quiet")))
236    (and (eq status :exited)
237         (eql exit-code 0))))
238
239;;; -----------------------------------------------------------------
240;;; authentication utils, for use with source control
241;;; -----------------------------------------------------------------
242;;; NOTE: currently unused, because we do not update from the GUI
243;;;       in the case that authentication is required. code left here
244;;;       for future reference
245
246(defparameter *authentication-window-controller* nil)
247
248(defclass authentication-window-controller (ns:ns-window-controller)
249    ((authentication-window :foreign-type :id :reader authentication-window)
250     (username-field :foreign-type :id :reader authentication-window-username-field)
251     (password-field :foreign-type :id :reader authentication-window-password-field))
252  (:metaclass ns:+ns-object))
253
254(objc:defmethod #/windowNibName ((self authentication-window-controller))
255  #@"Authenticate")
256
257(objc:defmethod (#/authOkay: :void) ((self authentication-window-controller) sender)
258  (declare (ignore sender))
259  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
260  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
261
262(objc:defmethod (#/authCancel: :void) ((self authentication-window-controller) sender)
263  (declare (ignore sender))
264  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
265  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
266
267(defun get-auth-window ()
268  (unless *authentication-window-controller*
269    (setf *authentication-window-controller* 
270          (make-instance 'authentication-window-controller))
271    (#/initWithWindowNibName: *authentication-window-controller* #@"Authenticate"))
272  (unless (#/isWindowLoaded *authentication-window-controller*)
273    (#/loadWindow *authentication-window-controller*))
274  (let ((window (authentication-window *authentication-window-controller*)))
275    (if (or (null window)
276            (%null-ptr-p window))
277        nil
278        window)))
279
280(defun get-svn-auth-data ()
281  (let ((auth-window (get-auth-window)))
282    (if auth-window
283        (let ((window-status (#/runModalForWindow: (#/sharedApplication (@class ns-application))
284                                                   auth-window)))
285          (if (zerop window-status)
286              nil
287              (let  ((username (lisp-string-from-nsstring (#/stringValue (authentication-window-username-field 
288                                                                          *authentication-window-controller*))))
289                     (password (lisp-string-from-nsstring (#/stringValue (authentication-window-password-field 
290                                                                          *authentication-window-controller*)))))
291                (cons username password))))
292        nil)))
293
294;;; -----------------------------------------------------------------
295;;; svn updates
296;;; -----------------------------------------------------------------
297
298(defun valid-revision-number-for-svn-update? (rev)
299  (and (stringp rev)
300       (plusp (length rev))))
301
302(defun valid-repository-for-svn-update? (url)
303  (url-p url))
304
305(defun valid-directory-for-svn-update? (dir)
306  (and dir
307       (probe-file dir)
308       (directoryp dir)
309       (validate-svn-data-pathname (merge-pathnames ".svn/" dir))))
310
311(defun svn-update-ccl (&key directory repository last-revision)
312  (cond
313    ((not (valid-directory-for-svn-update? directory)) 
314     (gui::alert-window :title "Update Failed"
315                        :message (format nil 
316                                         "Subversion update failed. CCL directory '~A' is not a valid working copy."
317                                         directory)))
318    ((not (valid-repository-for-svn-update? repository))
319     (gui::alert-window :title "Update Failed"
320                        :message (format nil "Subversion update failed. The supplied repository URL is invalid: '~A'"
321                                         repository)))
322    ((not (valid-revision-number-for-svn-update? last-revision))
323     (gui::alert-window :title "Update Failed"
324                        :message (format nil "Subversion update failed. CCL found an invalid revision number ('~A') for '~A'"
325                                         last-revision directory)))
326    (t (let ((status (svn-update directory)))
327         (if (zerop status)
328             (progn
329               ;; notify the user that the update succeeded and we'll now rebuild
330               (gui::alert-window :title "Update Succeeded"
331                        :message (format nil "Subversion updated CCL source directory '~A'. CCL needs to be rebuilt."
332                                         directory))
333               (ide-self-rebuild))
334             (gui::alert-window :title "Update Failed"
335                        :message (format nil "Subversion update of CCL directory '~A' failed with error code ~A."
336                                         directory status)))))))
337
338(defun run-svn-update-for-directory (dir)
339  (let* ((revision (svn-info-component "Revision:"))
340         (url (svn-url)))
341    (svn-update-ccl :directory dir :repository url :last-revision revision)))
342 
343(defun run-svn-update ()
344  (run-svn-update-for-directory (gui::find-ccl-directory)))
345
346(defun svn-update-available-p ()
347  (let ((ccl-dir (gui::find-ccl-directory)))
348    (if (valid-directory-for-svn-update? ccl-dir)
349        ;; compare revision number of working copy with repo
350        (let* ((local-revision (read-from-string (svn-revision)))
351               (repo (svn-repository))
352               (repo-info (parse-svn-info (svn-info repo)))
353               (repo-revision-entry (assoc "Revision" repo-info :test #'string=))
354               (repo-revision (or (and repo-revision-entry
355                                       (read-from-string (second repo-revision-entry)))
356                                  0)))
357          (< local-revision repo-revision))
358        nil)))
359
360;;; -----------------------------------------------------------------
361;;; app delegate extensions to handle self-update UI
362;;; -----------------------------------------------------------------
363
364(defparameter *update-ccl-window-controller* nil)
365
366(defclass update-ccl-window-controller (ns:ns-window-controller)
367    ((update-window :foreign-type :id :reader update-window))
368  (:metaclass ns:+ns-object))
369
370(objc:defmethod #/windowNibName ((self update-ccl-window-controller))
371  #@"updateCCL")
372
373(objc:defmethod (#/updateCCLOkay: :void) ((self update-ccl-window-controller) sender)
374  (declare (ignore sender))
375  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
376  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+)
377  (gui::with-modal-progress-dialog "Updating..."
378    "Getting changes from the CCL Repository..."
379   (run-svn-update))
380  (ide-self-rebuild))
381
382(objc:defmethod (#/updateCCLCancel: :void) ((self update-ccl-window-controller) sender)
383  (declare (ignore sender))
384  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
385  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
386
387(objc:defmethod (#/updateCCL: :void) ((self gui::ide-application-delegate)
388                                      sender)
389  (declare (ignore sender))
390  (if (check-svn)
391    (if (gui::with-modal-progress-dialog "Checking for Updates..."
392        "Checking for new CCL changes..."
393       (svn-update-available-p))
394      ;; newer version in the repo; display the update window
395      (progn
396        (when (null *update-ccl-window-controller*)
397          (setf *update-ccl-window-controller*
398                (make-instance 'update-ccl-window-controller))
399          (#/initWithWindowNibName: *update-ccl-window-controller* #@"updateCCL"))
400        (unless (#/isWindowLoaded *update-ccl-window-controller*)
401          (#/loadWindow *update-ccl-window-controller*))
402        (#/runModalForWindow: (#/sharedApplication (@class ns-application)) 
403                              (update-window *update-ccl-window-controller*)))
404      ;; no newer version available; display an informative alert window
405      (gui::alert-window :title "No Update Available"
406                         :message "No update is available. Your copy of CCL is up-to-date."))
407    ;; Can't execute svn.
408    (gui::alert-window :title "Can't run svn!"
409                       :message "The \"svn\" program can't be executed. If this is because it's installed in some directory not on this program's executable search path, setting CCL:*SVN-PROGRAM* to the full pathname of your \"svn\" program may fix this.")))
410
Note: See TracBrowser for help on using the repository browser.