375 lines
12 KiB
Plaintext
375 lines
12 KiB
Plaintext
;;;;
|
|
;;;; F i l e b o x . s t k -- File Box composite widget
|
|
;;;;
|
|
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|
;;;; software or derived works may only be charged with express written
|
|
;;;; permission of the copyright holder.
|
|
;;;; This software is provided ``as is'' without express or implied warranty.
|
|
;;;;
|
|
;;;; $Id: Filebox.stklos 1.6 Tue, 03 Mar 1998 22:48:24 +0000 eg $
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
;;;; Creation date: 22-Mar-1994 13:05
|
|
;;;; Last file update: 3-Mar-1998 22:54
|
|
|
|
(require "unix")
|
|
(require "Basics")
|
|
|
|
(select-module STklos+Tk)
|
|
|
|
(export make-file-box file-chooser)
|
|
|
|
;=============================================================================
|
|
;
|
|
; < F i l e - b o x >
|
|
;
|
|
;=============================================================================
|
|
|
|
;;;;
|
|
;;;; Resources
|
|
;;;;
|
|
|
|
(option 'add "*FileBox.FileName.Entry.Background" "white" "widgetDefault")
|
|
(option 'add "*FileBox.FileName.Entry.Relief" "sunken" "widgetDefault")
|
|
|
|
(option 'add "*FileBox*VPaned.Width" 450 "widgetDefault")
|
|
(option 'add "*FileBox*VPaned.Height" 200 "widgetDefault")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Utilities
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define filebox-lock #F) ;; lock variable
|
|
|
|
;;
|
|
;; Filebox-associate-bindings
|
|
;;
|
|
(define (filebox-associate-bindings fb)
|
|
|
|
(define & string-append)
|
|
|
|
(define (toggle-all-files)
|
|
(let ((val (slot-ref fb 'value)))
|
|
(unless (file-is-directory? val)
|
|
(set! val (dirname val)))
|
|
(slot-set! fb 'value val)
|
|
(filebox-scan-directory fb val)))
|
|
|
|
(define (choose-parent)
|
|
(let* ((lb (left-frame-of fb))
|
|
(sel (current-selection lb)))
|
|
(when sel
|
|
;; Read all component from 0 to sel and append them in a string
|
|
(let ((dir "")
|
|
(sel (car sel)))
|
|
(do ((i 1 (+ i 1)))
|
|
((> i sel))
|
|
(set! dir (& dir "/" (get lb i))))
|
|
(let ((new-dir (if (string=? dir "") "/" dir)))
|
|
(slot-set! fb 'value new-dir)
|
|
(filebox-scan-directory fb new-dir))))))
|
|
|
|
(define (choose-file)
|
|
(letrec ((box1 (left-frame-of fb))
|
|
(box2 (right-frame-of fb))
|
|
(sel (current-selection box2))
|
|
(res #t)
|
|
(make-dir (lambda (l res)
|
|
(if (null? l)
|
|
res
|
|
(make-dir (cdr l) (string-append res (car l) "/")))))
|
|
(val (& (make-dir (cdr (value box1)) "/") (get box2 (car sel)))))
|
|
|
|
(set! (value fb) val)
|
|
(if (file-is-directory? val)
|
|
(filebox-scan-directory fb val)
|
|
(filebox-validate fb))))
|
|
|
|
(define (complete-file)
|
|
(catch (let ((val (sort (glob (& (value fb) "*")) string<?)))
|
|
(when (= (length val) 1)
|
|
(let ((f (car val)))
|
|
(if (file-is-directory? f) (set! f (& f "/")))
|
|
(slot-set! fb 'value f)
|
|
(filebox-scan-directory fb f)))))
|
|
; Keep focus on the labeled entry widget
|
|
'break)
|
|
|
|
(define (invoke)
|
|
(let* ((box (right-frame-of fb))
|
|
(sel (current-selection box))
|
|
(val (value fb)))
|
|
(set! (value fb) (if (and (file-is-directory? val) sel)
|
|
(string-append val "/" (get box (car sel)))
|
|
val)))
|
|
(filebox-validate fb))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; filebox-associate-binding starts here
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(bind fb "<Destroy>" (lambda () (set! filebox-lock 'destroy)))
|
|
(set! (command (cancel-button-of fb))(lambda () (set! filebox-lock 'cancel)))
|
|
(set! (command (ok-button-of fb)) (lambda () (filebox-validate fb)))
|
|
(set! (command (all-button-of fb)) toggle-all-files)
|
|
(set! (command (help-button-of fb)) (lambda () (STk:show-help-file
|
|
"fbox-hlp.html")))
|
|
|
|
;; Button release in paned
|
|
(bind (listbox-of (left-frame-of fb)) "<Double-1>" choose-parent)
|
|
(bind (listbox-of (right-frame-of fb)) "<Double-1>" choose-file)
|
|
|
|
;; Character bindings in the entry
|
|
(let ((ent (lentry-of fb)))
|
|
(bind ent "<space>" complete-file)
|
|
(bind ent "<Tab>" complete-file)
|
|
(bind ent "<Return>" invoke))
|
|
)
|
|
|
|
;;
|
|
;; Filebox-scan-directory
|
|
;;
|
|
(define (filebox-scan-directory fb directory)
|
|
(let ((& string-append))
|
|
(when (file-is-directory? directory)
|
|
(let ((files (if (value (all-button-of fb))
|
|
(glob (& directory "/*") (& directory "/.*"))
|
|
(glob (& directory "/*")))))
|
|
;; Display the right part
|
|
(delete (right-frame-of fb) 0 'end)
|
|
(apply insert (right-frame-of fb) 0
|
|
(map (lambda (x) (basename x)) (sort files string<?)))
|
|
|
|
;; Display the left part
|
|
(delete (left-frame-of fb) 0 'end)
|
|
(apply insert (left-frame-of fb) 0 (decompose-file-name directory))))))
|
|
;;
|
|
;; Filebox-set-value!
|
|
;;
|
|
(define (filebox-set-value! fb value)
|
|
(let ((name (expand-file-name value)))
|
|
(if (file-is-directory? name)
|
|
;; Value given is a directory
|
|
(filebox-scan-directory fb name)
|
|
;; Value given is not a directory ...
|
|
(let ((parent (dirname name)))
|
|
(if (file-is-directory? parent)
|
|
;; ... and its parent is a valid directory
|
|
(filebox-scan-directory fb parent)
|
|
;; ... and its is not validd too.
|
|
(error "Directory ~S does not exist" parent))))
|
|
(set! (value (lentry-of fb)) name)))
|
|
|
|
;;
|
|
;; Filebox-validate
|
|
;;
|
|
(define (filebox-validate fb)
|
|
(if ((validate fb) fb (value fb))
|
|
(set! filebox-lock 'ok)))
|
|
|
|
;;
|
|
;; Filebox-wait-result
|
|
;;
|
|
(define (filebox-wait-result fb)
|
|
(let ((cur-grab (grab 'current fb)))
|
|
(tkwait 'visibility fb)
|
|
(grab 'set fb)
|
|
(tkwait 'variable 'filebox-lock)
|
|
(and cur-grab (grab 'set cur-grab))
|
|
|
|
;; Compute result
|
|
(case filebox-lock
|
|
((ok) (let ((res (value fb))) (destroy fb) res))
|
|
((cancel) (destroy fb) #f)
|
|
((destroy) #f))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Class definition
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define-class <File-box> (<Tk-composite-toplevel>)
|
|
((class :init-keyword :class
|
|
:init-form "FileBox")
|
|
(title :initform "File Selection"
|
|
:accessor title
|
|
:init-keyword :title
|
|
:allocation :propagated
|
|
:propagate-to (frame))
|
|
(validate :accessor validate
|
|
:init-form (lambda (fb path) #t)
|
|
:init-keyword :validate)
|
|
|
|
(paned) ;; paned and buttons are not intended to the user
|
|
(buttons)
|
|
(left-frame :accessor left-frame-of)
|
|
(right-frame :accessor right-frame-of)
|
|
(left-title :accessor left-title-of)
|
|
(right-title :accessor right-title-of)
|
|
(lentry :accessor lentry-of)
|
|
(ok-button :accessor ok-button-of)
|
|
(canc-button :accessor cancel-button-of)
|
|
(help-button :accessor help-button-of)
|
|
(all-button :accessor all-button-of)
|
|
;; Fictives slots
|
|
(value :accessor value
|
|
:init-keyword :value
|
|
:init-form (getcwd)
|
|
:allocation :virtual
|
|
:slot-ref (lambda (o)
|
|
(expand-file-name (value (lentry-of o))))
|
|
:slot-set! filebox-set-value!
|
|
:propagate-to (lentry))
|
|
(background :accessor background
|
|
:allocation :propagated
|
|
:propagate-to (frame buttons left-frame right-frame
|
|
left-title right-title lentry
|
|
ok-button canc-button help-button all-button))
|
|
(width :accessor width
|
|
:init-keyword :width
|
|
:allocation :propagated
|
|
:propagate-to (frame))
|
|
(height :accessor height
|
|
:init-keyword :height
|
|
:allocation :propagated
|
|
:propagate-to (frame))))
|
|
|
|
;==================================================
|
|
|
|
(define-method initialize-composite-widget ((self <File-box>) initargs frame)
|
|
(let* ((paned (make <VPaned> :parent frame :fraction 0.3))
|
|
(f (make <Frame> :parent frame))
|
|
(lf (left-frame-of paned))
|
|
(rf (right-frame-of paned)))
|
|
|
|
(next-method)
|
|
|
|
(slot-set! self 'Id (Id frame))
|
|
(slot-set! self 'paned paned)
|
|
(slot-set! self 'buttons f)
|
|
(slot-set! self 'left-frame (make <Scroll-Listbox> :parent lf))
|
|
(slot-set! self 'right-frame (make <Scroll-Listbox> :parent rf))
|
|
(slot-set! self 'left-title (make <Label> :parent lf :text "Parents"))
|
|
(slot-set! self 'right-title (make <Label> :parent rf :text "Files"))
|
|
(slot-set! self 'lentry (make <Labeled-entry> :parent frame
|
|
:class "FileName"
|
|
:title "File name"))
|
|
(slot-set! self 'ok-button (make <Button> :text "Ok" :parent f))
|
|
(slot-set! self 'canc-button (make <Button> :text "Cancel" :parent f))
|
|
(slot-set! self 'help-button (make <Button> :text "Help" :parent f))
|
|
(slot-set! self 'all-button (make <Check-button> :text "All"
|
|
:font "fixed" :parent f))
|
|
|
|
;; Pack everybody
|
|
(pack [left-title-of self] [right-title-of self] :fill "x") ; lists titles
|
|
(pack [left-frame-of self] ; paned
|
|
[right-frame-of self]
|
|
paned
|
|
:expand #t :fill "both" :padx 4 :pady 5)
|
|
(pack [lentry-of self] :fill "x" :padx 5 :pady 5) ; lentry
|
|
|
|
(pack [ok-button-of self] ; bottom buttons
|
|
[cancel-button-of self] :side 'left)
|
|
(pack [help-button-of self]
|
|
[all-button-of self]
|
|
:side 'right)
|
|
(pack f :fill "x" :side "bottom" :padx 4 :pady 4) ; bot but's frame
|
|
|
|
;; Don't export selection on Listboxes
|
|
(slot-set! (left-frame-of self) 'export-selection #f)
|
|
(slot-set! (right-frame-of self) 'export-selection #f)
|
|
|
|
;; Associate bindings
|
|
(filebox-associate-bindings self)
|
|
|
|
;; Initialize listboxes
|
|
'(filebox-scan-directory self (getcwd))))
|
|
|
|
|
|
;=============================================================================
|
|
;
|
|
; Tk:get-file / Tk:get-open-file / Tk:get-save-file
|
|
;
|
|
; User functions to ease usage of <File-box> class.
|
|
;
|
|
;=============================================================================
|
|
(when (eqv? (os-kind) 'Unix)
|
|
|
|
(define (file-read-validate fb file)
|
|
(or (and (file-exists? file)
|
|
(not (file-is-directory? file)))
|
|
(and (Tk:message-box :type 'ok
|
|
:text (format #f "File ~S does not exists" file))
|
|
#f)))
|
|
|
|
(define (file-write-validate fb file)
|
|
(if (file-exists? file)
|
|
(if (file-is-directory? file)
|
|
(begin
|
|
(Tk:message-box
|
|
:type 'ok
|
|
:text (format #f "~S is a directory" file))
|
|
#f)
|
|
(eqv? (Tk:message-box
|
|
:type 'yesno
|
|
:text (format #f "File ~S already exists\nOverwrite it?" file))
|
|
'yes))
|
|
#t))
|
|
|
|
;;;;
|
|
;;;; Tk:get-file
|
|
;;;;
|
|
(define (Tk:get-file . args)
|
|
(let* ((val (get-keyword :value args (getcwd)))
|
|
(title (get-keyword :title args ""))
|
|
(mode (get-keyword :mode args #f))
|
|
(f (make <File-Box> :value val :title title)))
|
|
;; Set filebox slots accordingly to option
|
|
(if mode
|
|
(set! (validate f)
|
|
(if (eqv? mode 'read) file-read-validate file-write-validate)))
|
|
|
|
;; wait a result
|
|
(filebox-wait-result f)))
|
|
|
|
;;;;
|
|
;;;; Tk:get-open-file
|
|
;;;;
|
|
(define (Tk:get-open-file . l)
|
|
(apply Tk:get-file
|
|
:mode 'read
|
|
:value (string-append (get-keyword :initial-dir l (getcwd))
|
|
"/"
|
|
(get-keyword :initial-file l ""))
|
|
l))
|
|
;;;;
|
|
;;;; Tk:get-save-file
|
|
;;;;
|
|
(define (Tk:get-save-file . l)
|
|
(apply Tk:get-file
|
|
:mode 'write
|
|
:value (string-append (get-keyword :initial-dir l (getcwd))
|
|
"/"
|
|
(get-keyword :initial-file l ""))
|
|
l))
|
|
)
|
|
;=============================================================================
|
|
;
|
|
; Make-file-boxFile-chooser (for compatibilty with old STk versions).
|
|
;
|
|
;=============================================================================
|
|
|
|
(define (make-file-box . title)
|
|
(if (null? title)
|
|
(Tk:get-file)
|
|
(Tk:get-file :title (car title))))
|
|
|
|
(provide "Filebox")
|