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

Last change on this file since 9689 was 9689, checked in by mikel, 14 years ago

debugged some svn info functions

File size: 12.2 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          svn-self.lisp
6;;;; Version:       0.1
7;;;; Project:       Cocoa IDE
8;;;; Purpose:       Cocoa UI for updating the Cocoa IDE from the source repo
9;;;;
10;;;; ***********************************************************************
11
12(in-package :ccl)
13(require :sequence-utils)
14
15;;; -----------------------------------------------------------------
16;;; svn metadata utils
17;;; -----------------------------------------------------------------
18
19;;; VALIDATE-SVN-DATA-PATHNAME p
20;;; -----------------------------------------------------------------
21;;; returns TRUE if P is really an existing directory that appears to
22;;; contain valid Subversion metadata; NIL otherwise
23
24(defmethod validate-svn-data-pathname ((p pathname))
25  (and (probe-file p)
26       (directoryp p)
27       (string= ".svn" (first (last (pathname-directory p))))
28       ;; if we reached this point, it's an existing directory
29       ;; named ".svn". now, does it have Subversion metadata files
30       ;; in it?
31       (let ((subversion-metafiles '("dir-prop-base" "entries" "format"
32                                     "prop-base/" "props/" "text-base/")))
33         (every (lambda (f) (probe-file (merge-pathnames f p))) 
34                subversion-metafiles))))
35
36(defmethod validate-svn-data-pathname ((p string))
37  (validate-svn-data-pathname (pathname p)))
38
39;;; -----------------------------------------------------------------
40;;; url utils
41;;; -----------------------------------------------------------------
42
43;;; URL-P thing
44;;; -----------------------------------------------------------------
45;;; returns true if THING is a string that appears to contain a URL,
46;;; NIL otherwise
47
48(defmethod url-p (thing)
49  (declare (ignore thing))
50  nil)
51
52(defmethod url-p ((url string))
53  (if (find-matching-subsequence "://" url)
54      t
55      nil))
56
57;;; URL-PROTOCOL url
58;;; -----------------------------------------------------------------
59;;; returns the protocol pprtion of the URL, or NIL if none
60;;; can be identified
61
62(defmethod url-protocol ((url string))
63  (let ((index (find-matching-subsequence "://" url)))
64    (if index
65        (subseq url 0 index)
66        nil)))
67
68;;; URL-HOST url
69;;; -----------------------------------------------------------------
70;;; returns two values:
71;;; 1. the hostname of the URL
72;;; 2. the username portion of the host segment, if any, or NIL
73
74(defmethod url-host ((url string))
75  (let* ((protocol-marker "://")
76         (protocol-marker-index (find-matching-subsequence protocol-marker url)))
77    (if protocol-marker-index
78        (let* ((protocol-end-index (+ protocol-marker-index (length protocol-marker)))
79               (host-end-index (find-matching-subsequence "/" url :start protocol-end-index))
80               (host-segment (subseq url protocol-end-index host-end-index))
81               (username-terminus-index (find-matching-subsequence "@" host-segment))
82               (username (if username-terminus-index
83                             (subseq host-segment 0 username-terminus-index)
84                             nil))
85               (host (if username-terminus-index
86                         (subseq host-segment (1+ username-terminus-index))
87                         host-segment)))
88          (values host username))
89        nil)))
90
91;;; URL-PATH url
92;;; -----------------------------------------------------------------
93;;; returns the pathname portion of a URL, or NIL if none can be identified
94
95(defmethod url-path ((url string))
96  (let* ((protocol-marker "://")
97         (protocol-marker-index (find-matching-subsequence protocol-marker url)))
98    (if protocol-marker-index
99        (let* ((protocol-end-index (+ protocol-marker-index (length protocol-marker)))
100               (host-end-index (find-matching-subsequence "/" url :start protocol-end-index)))
101          (if host-end-index
102              (subseq url host-end-index)
103              nil))
104        nil)))
105
106;;; -----------------------------------------------------------------
107;;; getting svn info
108;;; -----------------------------------------------------------------
109
110(defmethod svn-info ((p string))
111  (with-output-to-string (out)
112     (run-program "svn" `("info" ,p) :output out)))
113
114(defmethod svn-info ((p pathname))
115  (svn-info (namestring p)))
116
117(defmethod split-svn-info-line ((line string))
118  (let* ((split-sequence ": ")
119         (split-index (find-matching-subsequence split-sequence line :test #'char=))
120         (prefix (subseq line 0 split-index))
121         (suffix (subseq line (if split-index
122                                  (+ split-index (length split-sequence))
123                                  (length line)))))
124    (list prefix suffix)))
125
126(defmethod parse-svn-info ((info-string string))
127  (let ((info-lines (split-lines info-string)))
128    (mapcar #'split-svn-info-line info-lines)))
129
130(defun svn-revision ()
131  (svn-info-component "Revision:"))
132
133;;; -----------------------------------------------------------------
134;;; authentication utils, for use with source control
135;;; -----------------------------------------------------------------
136;;; NOTE: currently unused, because we do not update from the GUI
137;;;       in the case that authentication is required. code left here
138;;;       for future reference
139
140(defparameter *authentication-window-controller* nil)
141
142(defclass authentication-window-controller (ns:ns-window-controller)
143    ((authentication-window :foreign-type :id :reader authentication-window)
144     (username-field :foreign-type :id :reader authentication-window-username-field)
145     (password-field :foreign-type :id :reader authentication-window-password-field))
146  (:metaclass ns:+ns-object))
147
148(objc:defmethod #/windowNibName ((self authentication-window-controller))
149  #@"Authenticate")
150
151(objc:defmethod (#/authOkay: :void) ((self authentication-window-controller) sender)
152  (declare (ignore sender))
153  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
154  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
155
156(objc:defmethod (#/authCancel: :void) ((self authentication-window-controller) sender)
157  (declare (ignore sender))
158  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
159  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
160
161(defun get-auth-window ()
162  (unless *authentication-window-controller*
163    (setf *authentication-window-controller* 
164          (make-instance 'authentication-window-controller))
165    (#/initWithWindowNibName: *authentication-window-controller* #@"Authenticate"))
166  (unless (#/isWindowLoaded *authentication-window-controller*)
167    (#/loadWindow *authentication-window-controller*))
168  (let ((window (authentication-window *authentication-window-controller*)))
169    (if (or (null window)
170            (%null-ptr-p window))
171        nil
172        window)))
173
174(defun get-svn-auth-data ()
175  (let ((auth-window (get-auth-window)))
176    (if auth-window
177        (let ((window-status (#/runModalForWindow: (#/sharedApplication (@class ns-application))
178                                                   auth-window)))
179          (if (zerop window-status)
180              nil
181              (let  ((username (lisp-string-from-nsstring (#/stringValue (authentication-window-username-field 
182                                                                          *authentication-window-controller*))))
183                     (password (lisp-string-from-nsstring (#/stringValue (authentication-window-password-field 
184                                                                          *authentication-window-controller*)))))
185                (cons username password))))
186        nil)))
187
188;;; -----------------------------------------------------------------
189;;; svn updates
190;;; -----------------------------------------------------------------
191
192(defun valid-revision-number-for-svn-update? (rev)
193  (and (stringp rev)
194       (plusp (length rev))))
195
196(defun valid-repository-for-svn-update? (url)
197  (url-p url))
198
199(defun valid-directory-for-svn-update? (dir)
200  (and dir
201       (probe-file dir)
202       (directoryp dir)
203       (validate-svn-data-pathname (merge-pathnames ".svn/" dir))))
204
205(defun svn-update-ccl (&key directory repository last-revision)
206  (cond
207    ((not (valid-directory-for-svn-update? directory)) 
208     (gui::alert-window :title "Update Failed"
209                   :message (format nil 
210                                    "Subversion update failed. CCL directory '~A' doesn't exist, or lacks valid Subversion metadata."
211                                    directory)))
212    ((not (valid-repository-for-svn-update? repository))
213     (gui::alert-window :title "Update Failed"
214                   :message (format nil "Subversion update failed. The supplied repository URL is invalid: '~A'"
215                                    repository)))
216    ((not (valid-revision-number-for-svn-update? last-revision))
217     (gui::alert-window :title "Update Failed"
218                   :message (format nil "Subversion update failed. CCL found an invalid revision number for the current working copy: '~A'"
219                                    last-revision)))
220    (t (gui::alert-window :title "Update Succeeded"
221                     :message "Subversion update succeeded. Soon we will actually run the update when it succeeds."))))
222
223(defun run-svn-update-for-directory (dir)
224  (let* ((revision (svn-info-component "Revision:"))
225         (url (svn-url)))
226    (svn-update-ccl :directory dir :repository url :last-revision revision)))
227 
228(defun run-svn-update ()
229  (run-svn-update-for-directory (gui::find-ccl-directory)))
230
231(defun svn-update-available-p ()
232  (let ((ccl-dir (gui::find-ccl-directory)))
233    (if (valid-directory-for-svn-update? ccl-dir)
234        ;; compare revision number of working copy with repo
235        (let* ((local-revision (read-from-string (svn-revision)))
236               (repo (svn-repository))
237               (repo-info (parse-svn-info (svn-info repo)))
238               (repo-revision-entry (assoc "Revision:" repo-info :test #'string=))
239               (repo-revision (or (and repo-revision-entry
240                                       (read-from-string (second repo-revision-entry)))
241                                  0)))
242          (< local-revision repo-revision))
243        nil)))
244
245;;; -----------------------------------------------------------------
246;;; app delegate extensions to handle self-update UI
247;;; -----------------------------------------------------------------
248
249(defparameter *update-ccl-window-controller* nil)
250
251(defclass update-ccl-window-controller (ns:ns-window-controller)
252    ((update-window :foreign-type :id :reader update-window))
253  (:metaclass ns:+ns-object))
254
255(objc:defmethod #/windowNibName ((self update-ccl-window-controller))
256  #@"updateCCL")
257
258(objc:defmethod (#/updateCCLOkay: :void) ((self update-ccl-window-controller) sender)
259  (declare (ignore sender))
260  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
261  (run-svn-update)
262  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
263
264(objc:defmethod (#/updateCCLCancel: :void) ((self update-ccl-window-controller) sender)
265  (declare (ignore sender))
266  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
267  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
268
269(objc:defmethod (#/updateCCL: :void) ((self lisp-application-delegate)
270                                      sender)
271  (declare (ignore sender))
272  (if (svn-update-available-p)
273      ;; newer version in the repo; display the update window
274      (progn
275        (when (null *update-ccl-window-controller*)
276          (setf *update-ccl-window-controller*
277                (make-instance 'update-ccl-window-controller))
278          (#/initWithWindowNibName: *update-ccl-window-controller* #@"updateCCL"))
279        (unless (#/isWindowLoaded *update-ccl-window-controller*)
280          (#/loadWindow *update-ccl-window-controller*))
281        (#/runModalForWindow: (#/sharedApplication (@class ns-application)) 
282                              (update-window *update-ccl-window-controller*)))
283      ;; no newer version available; display an informative alert window
284      (gui::alert-window :title "No Update Available"
285                         :message "No update is available. Your copy of CCL is up-to-date.")))
286
Note: See TracBrowser for help on using the repository browser.