;;;;
;;;; F i l e b o x . s t k 	  --  File Box composite widget
;;;;
;;;; Copyright (C) 1993,1994,1995 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.
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date: 22-Mar-1994 13:05
;;;; Last file update:  5-Aug-1994 16:07

(require "unix")
(require "Toplevel")
(require "Button")
(require "Paned")
(require "Scrollbox")
(require "Lentry")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <File-box> class-definition
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define-class <File-box> (<Tk-composite-widget>)
  (paned	 		;; paned and button 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)
   but-frame
   (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
		 :allocation   :propagated
		 :propagate-to (lentry))
   (background   :accessor     background
		 :allocation   :propagated
		 :propagate-to (frame paned buttons left-frame right-frame 
				left-title right-title lentry 
				ok-button canc-button help-button all-button))
   (geometry	 :accessor     geometry
		 :init-keyword :geometry
		 :allocation   :propagated
		 :propagate-to (frame))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; <File-box> methods
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;; Interface
;;; 

(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)))

    (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 
				       			: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 files" 
				       		      :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]
	  [all-button-of self]
	  [help-button-of self]
	  :side "left" :expand #t :ipadx 3 :ipady 3)
    (pack f :fill "x" :side "bottom" :padx 10 :pady 10)		; bot but's frame

    ;; Set grip visible
    (set! (background (grip-of paned)) "red")

    ;; Set geometry of this widget (necessary to avoid a 0x0 widget).
    (slot-set! paned 'geometry (get-keyword :geometry initargs "400x200"))

    ;; 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 
    (associate-bindings self)

    ;; Initialize listboxes
    (slot-set! self 'value (getcwd))
    (scan-directory self)))

;;;;
;;;; Bindings association
;;;;
(define-method associate-bindings ((self <File-box>))
  (let ((address (address-of self)))
    ;; All files button
    (slot-set! (all-button-of self) 'command `(toggle-all-files ,address))

    ;; Help button
    (slot-set! (help-button-of self) 'command `(STk:make-help File-Box-Help))

    ;; Button release in paned
    (bind (listbox-of (left-frame-of self))
	  "<Double-1>" `(choose-parent ,address))
    (bind (listbox-of (right-frame-of self))
	  "<Double-1>" `(choose-file   ,address))

    ;; Tab in the entry
    (bind (entry-of (lentry-of self)) "<space>" `(complete-file ,address))
    (bind (entry-of (lentry-of self)) "<Tab>"   `(complete-file ,address))

    ;; Return in the entry
    (bind (entry-of (lentry-of self)) "<Return>" `(invoke ,address))
))


;;;
;;; Directory listing
;;;
(define-method scan-directory ((self <File-box>))
  (let ((directory (slot-ref self 'value)))

    (when (file-is-directory? directory)
       (let ((files (if (equal? (value (all-button-of self)) "1")
			(glob (& directory "/*") (& directory "/.*"))
			(glob (& directory "/*")))))
    
	 ;; Display the right part
	 (delete (right-frame-of self) 0 'end)
	 (apply insert (right-frame-of self) 0 
		(map (lambda (x) (basename x)) (sort files string<?)))

	 ;; Display the left part
	 (delete (left-frame-of self) 0 'end)
	 (apply insert (left-frame-of self) 0 (decompose-file-name directory))))
    
    ;;Display current directory in the labeled entry
    (slot-set! self 'value directory)))


;;;;
;;;; toggle-all-files
;;;; 
(define-method toggle-all-files ((self <File-box>))
  (let ((val (slot-ref self 'value)))
    (unless (file-is-directory? val)
       (slot-set! self 'value (dirname val))))
  (scan-directory self))


;;;;
;;;; choose-parent
;;;;
(define-method choose-parent ((self <File-box>))
  (let* ((lb  (left-frame-of self))
	 (sel (current-selection lb)))
    (when  sel
       ;; Read all component from 0 to sel and append them in a string
       (let ((dir ""))
	 (do ((i 1 (+ i 1)))
	     ((> i sel))
	   (set! dir (& dir "/" (get lb i))))
	 (slot-set! self 'value (if (string=? dir "") "/" dir)))
       (scan-directory self))))

;;;;
;;;; choose-file
;;;;
(define-method choose-file ((self <File-box>))
  (let* ((lb  (right-frame-of self))
	 (sel (current-selection lb)))
    (when  sel
       (let ((val (& (slot-ref self 'value) "/" (get lb sel))))
	 (if (file-is-directory? val)
	     (begin
	       ;; Make a new file name
	       (catch 
		  (let ((cur (getcwd)))
		    ;; Make a pretty file name (i.e. avoid things such as /a/b/../c)
		    (chdir val)
		    (set! val (getcwd))
		    (chdir cur)))
	       (slot-set! self 'value val)
	       (scan-directory self))
	     (invoke self))))))

;;;
;;; complete-file
;;;
(define-method complete-file ((self <File-Box>))
  (let ((val (sort (glob (& (value self) "*")) string<?)))
    (when (= (length val) 1)
       (let ((f (car val)))
	 (if (file-is-directory? f) (set! f (& f "/")))
	 (slot-set! self 'value f))
       (scan-directory self))))

;;;
;;; invoke
;;;
(define-method invoke ((self <File-box>))
  (invoke (ok-button-of self)))


;;;;
;;;; Help
;;;;

(define File-Box-Help  '("STF-0.1" "
File Box help

This file box is an instance of the <File-box> composite class.

Parents list contains current path exploded with one directory per line. This permits a rapid access to the hierarchy

Files list contains the files of the current directory. Special files (i.e dotted files) are shown iff the check button All files is set.

A file name can also be typed in. In this case, the Tab key can be used to perform automatic completion.


" ((bold-12 ("6.0" "6.12" "8.0" "8.10")) (italic-12 ("8.120" "8.129" "10.83" "10.104")) (roman-18 ("2.0" "2.13")) (fixed ("4.36" "4.46" "10.52" "10.55")))))





;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; make-file-box
;;;;		User function which permits to create a toplevel containing a 
;;;;		file selection box. Result is the value of the file choosen
;;;;		or #f if the CANCEL button has been depressed
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define stk:filebox-result #T)	;; result variable 
(define stk:filebox-lock   #F)  ;; lock variable

(define (file-box-value fb)
  (let* ((lb  (right-frame-of fb))
	 (sel (current-selection lb))
	 (val (value fb)))
    (if (file-is-directory? val)
	(& val (if sel (& "/" (get lb sel)) ""))
	val)))

(define (make-file-box . title)
  (let* ((t (make <Toplevel> :class "FileSelector"))
	 (f (make <File-Box> :parent t)))

    ;; map the filebox
    (pack f :expand #t :fill "both")

    ;; Window manager customization
    (wm 'max t 1000 1000)
    (wm 'title t (if (null? title) "File Selection" (car title)))

    ;; Associate actions to Ok and Cancel button
    (set! (command (ok-button-of f))     `(begin
					    (set! stk:filebox-result 
						  (file-box-value ,(address-of f)))
					    (set! stk:filebox-lock 'ok)))
    (set! (command (cancel-button-of f)) `(begin
					    (set! stk:filebox-result #f)
					    (set! stk:filebox-lock 'cancel)))
    (bind t "<Destroy>" 		 `(set! stk:filebox-lock 'destroy))

    ;; and now wait an event
    (tkwait 'variable 'stk:filebox-lock)

    ;; Destroy the window
    (catch (destroy t))
    ;; Return the value of stk:filebox-result
    stk:filebox-result))


(provide "Filebox")