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

added rcs key bindings

Browse Source 
original commit: 9704dfc296a70d5889f6c724c97cbef8e90fd3c8
This commit is contained in:
Robby Findler 1996-06-21 21:49:56 +00:00
parent 20998198b4
commit 84d169fc5c
1 changed files with 52 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/mred/keys.ss
View File

@ -1,6 +1,7 @@
(define mred:keymap@
(unit/sig mred:keymap^
(import [mred:debug : mred:debug^]
[mred:preferences : mred:preferences^]
[mred:finder : mred:finder^]
[mred:handler : mred:handler^]
[mred:find-string : mred:find-string^]
@ -42,7 +43,52 @@
; This installs the standard keyboard mapping
(define setup-global-keymap
; Define some useful keyboard functions
(let* ([ring-bell
(let* ([rcs
(let ([last-checkin-string ""])
(mred:preferences:set-preference-default 'rcs-pathname "/usr/local/RCS/")
(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")))))]))))))]
[ring-bell
(lambda (edit event)
(send (let loop ([p (send event get-event-object)])
(let ([parent (send p get-parent)])
@ -586,6 +632,8 @@
(wx:add-media-pasteboard-functions kmap)
; Map names to keyboard functions
(add "rcs" rcs)
(add "ring-bell" ring-bell)
(add "save-file" save-file)
@ -636,6 +684,9 @@
(add "goto-position" goto-position)
; Map keys to functions
(when (eq? wx:platform 'unix)
(map "c:x;c:q" "rcs"))
(map "c:g" "ring-bell")
(map-meta "c:g" "ring-bell")
(map "c:x;c:g" "ring-bell")