suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed up a little rcs bug

Browse Source 
original commit: acdb133697c73b8c72dafec8b146a07c7c323bb1
This commit is contained in:
Robby Findler 1996-06-22 21:19:34 +00:00
parent 1d734bbbbf
commit 624c9129a8
1 changed files with 64 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/mred/keys.ss
View File

@ -5,7 +5,8 @@
[mred:finder : mred:finder^]
[mred:handler : mred:handler^]
[mred:find-string : mred:find-string^]
[mred:scheme-paren : mred:scheme-paren^])
[mred:scheme-paren : mred:scheme-paren^]
[mred:gui-utils : mred:gui-utils^])
(mred:debug:printf 'invoke "mred:keymap@")
@ -45,48 +46,69 @@
; Define some useful keyboard functions
(let* ([rcs
(let ([last-checkin-string ""])
(mred:preferences:set-preference-default 'rcs-pathname "/usr/local/RCS/")
(mred:preferences:set-preference-default
'rcs-pathname (list "/usr/local/RCS/" "/usr/bin/" "/usr/local/bin/"))
(lambda (edit event)
(let* ([rcs-pathname (mred:preferences:get-preference 'rcs-pathname)]
[filename (send edit get-filename)]
[username (wx:get-user-id)])
(let-values ([(my-out my-in my-pid my-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" (string-append "-l" username) filename))]
[(their-out their-in their-pid their-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" "-l" filename))])
(let ([my-lock? (not (eof-object? (read my-out)))]
[locked? (not (eof-object? (read their-out)))])
(for-each close-input-port (list my-out my-err their-out their-err))
(for-each close-output-port (list my-in their-in))
(cond
[(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename))
(system* (build-path rcs-pathname "ci") "-t-" filename)
(wx:message-box "Initial Checking Completed")]
[my-lock?
(let* ([msg (wx:get-text-from-user "Please Enter Log Message"
"Check In"
last-checkin-string)]
[result (system* (build-path rcs-pathname "ci")
"-u" (string-append "-m" msg) filename)])
(set! last-checkin-string msg)
(unless result
(wx:message-box "Checkin Unsucessful")))]
[locked? (wx:message-box "Someone else has the lock")]
[else
(let ([current-dir (current-directory)])
(let-values ([(base name _) (split-path filename)])
(unless (eq? 'relative base)
(current-directory base))
(let ([res (system* (build-path rcs-pathname "co")
"-q" "-l" name)])
(current-directory current-dir)
(if res
(send edit load-file
(send edit get-filename)
(send edit get-file-format))
(wx:message-box "Checkout Failed")))))]))))))]
(let/ec k
(let* ([rcs-binaries (list "ci" "co" "rlog")]
[rcs-pathname (let loop ([paths (mred:preferences:get-preference 'rcs-pathname)])
(cond
[(null? paths) (k (wx:message-box "could not find RCS binaries."))]
[else (if (andmap (lambda (b)
(file-exists? (build-path (car paths) b)))
rcs-binaries)
(car paths)
(loop (cdr paths)))]))]
[filename (send edit get-filename)]
[username (wx:get-user-id)])
(when (null? filename)
(k (wx:message-box "no file associated with this edit")))
(let-values ([(my-out my-in my-pid my-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" (string-append "-l" username) filename))]
[(their-out their-in their-pid their-err)
(apply values (process* (build-path rcs-pathname "rlog")
"-L" "-R" "-l" filename))])
(let ([my-lock? (not (eof-object? (read my-out)))]
[locked? (not (eof-object? (read their-out)))])
(for-each close-input-port (list my-out my-err their-out their-err))
(for-each close-output-port (list my-in their-in))
(cond
[(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename))
(system* (build-path rcs-pathname "ci") "-t-" filename)
(wx:message-box "Initial Checkin Completed")]
[my-lock?
(when (send edit modified?)
(case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t)
[(save) (send edit save-file (send edit get-filename)
(send edit get-file-format))]
[(cancel) (k (void))]
[else (void)]))
(let* ([msg (wx:get-text-from-user "Please Enter Log Message"
"Check In"
last-checkin-string)]
[result (system* (build-path rcs-pathname "ci")
"-u" (string-append "-m" msg) filename)])
(set! last-checkin-string msg)
(if result
(send edit load-file
(send edit get-filename)
(send edit get-file-format))
(wx:message-box "Checkin Unsucessful")))]
[locked? (wx:message-box "Someone else has the lock")]
[else
(let ([current-dir (current-directory)])
(let-values ([(base name _) (split-path filename)])
(unless (eq? 'relative base)
(current-directory base))
(let ([res (system* (build-path rcs-pathname "co")
"-q" "-l" name)])
(current-directory current-dir)
(if res
(send edit load-file
(send edit get-filename)
(send edit get-file-format))
(wx:message-box "Checkout Failed")))))])))))))]
[ring-bell
(lambda (edit event)