97 lines
2.8 KiB
Scheme
97 lines
2.8 KiB
Scheme
;;; -*-Scheme-*-
|
|
;;;
|
|
;;; List widget demo (directory browser) for Motif
|
|
|
|
(require 'motif)
|
|
(require 'unix)
|
|
(require 'sort 'qsort.scm)
|
|
|
|
(define top (application-initialize 'list))
|
|
(set-values! top 'allow-shell-resize #t)
|
|
|
|
(define form (create-managed-widget (find-class 'form) top))
|
|
|
|
(define quit (create-managed-widget (find-class 'push-button) form))
|
|
(set-values! quit 'left-attachment "ATTACH_FORM"
|
|
'top-attachment "ATTACH_FORM"
|
|
'width 50
|
|
'height 30
|
|
'border-width 1
|
|
'label-string "quit")
|
|
|
|
(add-callback quit 'activate-callback (lambda x (destroy-widget top)
|
|
(exit)))
|
|
|
|
(define back (create-managed-widget (find-class 'push-button) form))
|
|
(set-values! back 'left-attachment "ATTACH_WIDGET"
|
|
'left-widget quit
|
|
'top-attachment "ATTACH_FORM"
|
|
'width 50
|
|
'height 30
|
|
'border-width 1
|
|
'label-string "back")
|
|
|
|
(add-callback back 'activate-callback (lambda x (goto "..")))
|
|
|
|
(define lab (create-managed-widget (find-class 'label) form))
|
|
(set-values! lab 'border-width 0
|
|
'left-attachment "ATTACH_WIDGET"
|
|
'left-widget back
|
|
'top-attachment "ATTACH_FORM"
|
|
'right-attachment "ATTACH_FORM"
|
|
'right-offset 4
|
|
'top-offset 4
|
|
'height 30
|
|
'recompute-size #t)
|
|
|
|
(define lst (create-managed-widget (find-class 'list) form ))
|
|
(set-values! lst 'left-attachment "ATTACH_FORM"
|
|
'top-attachment "ATTACH_WIDGET"
|
|
'top-widget quit
|
|
'right-attachment "ATTACH_FORM"
|
|
'bottom-attachment "ATTACH_FORM"
|
|
'list-size-policy "VARIABLE"
|
|
'list-margin-width 5
|
|
'selection-policy "BROWSE_SELECT")
|
|
|
|
(add-callback lst 'browse-selection-callback
|
|
(lambda (w i)
|
|
(let ((type (stat-type (unix-stat (string-append
|
|
where "/" (car (last-pair i)))))))
|
|
(set-values! lab 'label-string type)
|
|
(if (eq? type 'directory)
|
|
(goto (car (last-pair i)))))))
|
|
|
|
(define (goto dir)
|
|
(if (string=? dir "..")
|
|
(begin
|
|
(if (not (string=? where "/"))
|
|
(begin
|
|
(set! where
|
|
(substring where 0
|
|
(do ((i (- (string-length where) 2) (1- i)))
|
|
((char=? (string-ref where i) #\/) i))))
|
|
(if (eqv? where "")
|
|
(set! where "/")))))
|
|
(if (not (or (string=? dir "/") (string=? where "/")))
|
|
(set! where (string-append where "/")))
|
|
(set! where (string-append where dir)))
|
|
(set-values! lab 'label-string where)
|
|
(define l '())
|
|
(for-each (lambda (d) (if (not (member d '("." "..")))
|
|
(set! l (cons d l))))
|
|
(unix-read-directory where))
|
|
(if (null? l)
|
|
(set-values! lst 'items l 'item-count 0 'visible-item-count 1)
|
|
(set-values! lst 'items (sort l string<?) 'item-count (length l)
|
|
'visible-item-count (length l))))
|
|
|
|
(define where "")
|
|
|
|
(goto "/")
|
|
|
|
(set-values! lab 'label-string "Select directory:")
|
|
|
|
(realize-widget top)
|
|
(context-main-loop (widget-context top))
|