home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Filebox.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  9.3 KB  |  294 lines
  1. ;;;;
  2. ;;;; F i l e b o x . s t k       --  File Box composite widget
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 22-Mar-1994 13:05
  16. ;;;; Last file update:  2-Jul-1996 12:08
  17.  
  18. (require "unix")
  19. (require "Tk-classes")
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;;;
  23. ;;;; <File-box> class-definition
  24. ;;;;
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (define-class <File-box> (<Tk-composite-widget>)
  28.   (paned             ;; paned and button are not intended to the user
  29.    buttons
  30.    (left-frame  :accessor left-frame-of)
  31.    (right-frame :accessor right-frame-of)
  32.    (left-title  :accessor left-title-of)
  33.    (right-title :accessor right-title-of)
  34.    (lentry    :accessor lentry-of)
  35.    but-frame
  36.    (ok-button    :accessor ok-button-of)
  37.    (canc-button :accessor cancel-button-of)
  38.    (help-button :accessor help-button-of)
  39.    (all-button  :accessor all-button-of)
  40.  
  41.    ;; Fictives slots
  42.    (value     :accessor     value
  43.          :allocation   :propagated
  44.          :propagate-to (lentry))
  45.    (background   :accessor     background
  46.          :allocation   :propagated
  47.          :propagate-to (frame paned buttons left-frame right-frame 
  48.                 left-title right-title lentry 
  49.                 ok-button canc-button help-button all-button))
  50.    (width     :accessor     width
  51.          :init-keyword :width
  52.          :allocation   :propagated
  53.          :propagate-to (frame))
  54.    (height     :accessor     height
  55.          :init-keyword :height
  56.          :allocation   :propagated
  57.          :propagate-to (frame))))
  58.  
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60. ;;;;
  61. ;;;; <File-box> methods
  62. ;;;;
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64.  
  65. ;;;
  66. ;;; Interface
  67. ;;; 
  68.  
  69. (define-method initialize-composite-widget ((self <File-box>) initargs frame)
  70.   (let* ((paned  (make <VPaned> :parent frame :fraction 0.3))
  71.      (f      (make <Frame>  :parent frame))
  72.      (lf     (left-frame-of  paned))
  73.      (rf     (right-frame-of paned)))
  74.  
  75.     (slot-set! self 'paned      paned)
  76.     (slot-set! self 'buttons     f) 
  77.     (slot-set! self 'left-frame  (make <Scroll-Listbox> :parent lf))
  78.     (slot-set! self 'right-frame (make <Scroll-Listbox> :parent rf))
  79.     (slot-set! self 'left-title  (make <Label>          :parent lf :text "Parents"))
  80.     (slot-set! self 'right-title (make <Label>          :parent rf :text "Files"))
  81.     (slot-set! self 'lentry     (make <Labeled-entry>  :parent frame 
  82.                                    :title "File name"))
  83.     (slot-set! self 'ok-button   (make <Button> :text " Ok "     :parent f))
  84.     (slot-set! self 'canc-button (make <Button> :text " Cancel " :parent f))
  85.     (slot-set! self 'help-button (make <Button> :text " Help "   :parent f))
  86.     (slot-set! self 'all-button     (make <Check-button> :text "All files" 
  87.                        :parent f))
  88.  
  89.     ;; Pack everybody
  90.     (pack [left-title-of self] [right-title-of self] :fill "x") ; lists titles
  91.     (pack [left-frame-of self]                    ; paned
  92.       [right-frame-of self]
  93.       paned
  94.       :expand #t :fill "both" :padx 4 :pady 5)
  95.     (pack [lentry-of self] :fill "x" :padx 5 :pady 5)        ; lentry
  96.     (pack [ok-button-of self]                    ; bottom buttons
  97.       [cancel-button-of self]
  98.       [all-button-of self]
  99.       [help-button-of self]
  100.       :side "left" :expand #t :ipadx 3 :ipady 3)
  101.     (pack f :fill "x" :side "bottom" :padx 10 :pady 10)        ; bot but's frame
  102.  
  103.     ;; Set grip visible
  104.     (set! (background (grip-of paned)) "red")
  105.  
  106.     ;; Set geometry of this widget (necessary to avoid a 0x0 widget).
  107.     (slot-set! paned 'width  (get-keyword :width  initargs 400))
  108.     (slot-set! paned 'height (get-keyword :height initargs 200))
  109.  
  110.     ;; Don't export selection on Listboxes
  111.     (slot-set! (left-frame-of  self) 'export-selection #f)
  112.     (slot-set! (right-frame-of self) 'export-selection #f)
  113.  
  114.     ;; Associate bindings 
  115.     (STk:associate-bindings self)
  116.  
  117.     ;; Initialize listboxes
  118.     (let ((dir (getcwd)))
  119.       (slot-set! self 'value dir)
  120.       (scan-directory self dir))))
  121.  
  122. ;;;;
  123. ;;;; Bindings association
  124. ;;;;
  125. (define-method STk:associate-bindings ((self <File-box>))
  126.   (let ((directory (slot-ref self 'value))
  127.     (&       string-append))
  128.     ;;
  129.     ;; toggle-all-files
  130.     ;; 
  131.     (define (toggle-all-files fb)
  132.       (let ((val (slot-ref fb 'value)))
  133.     (unless (file-is-directory? val)
  134.       (set! val (dirname val)))
  135.     (slot-set! fb 'value val)
  136.     (scan-directory fb val)))
  137.  
  138.     ;;
  139.     ;; choose-parent
  140.     ;;
  141.     (define (choose-parent fb)
  142.       (let* ((lb  (left-frame-of fb))
  143.          (sel (current-selection lb)))
  144.     (when  sel
  145.         ;; Read all component from 0 to sel and append them in a string
  146.         (let ((dir "")
  147.           (sel (car sel)))
  148.           (do ((i 1 (+ i 1)))
  149.           ((> i sel))
  150.         (set! dir (& dir "/" (get lb i))))
  151.           (let ((new-dir (if (string=? dir "") "/" dir)))
  152.         (slot-set! fb 'value new-dir)
  153.         (scan-directory fb new-dir))))))
  154.  
  155.     ;;
  156.     ;; choose-file
  157.     ;;
  158.     (define (choose-file fb)
  159.       (let* ((lb  (right-frame-of fb))
  160.          (sel (current-selection lb)))
  161.     (when  sel
  162.         (let* ((sel (car sel))
  163.            (val (& (slot-ref fb 'value) "/" (get lb sel))))
  164.           (if (file-is-directory? val)
  165.           (begin
  166.             ;; Make a new file name
  167.             (catch 
  168.              (let ((cur (getcwd)))
  169.                ;; Make a pretty name (i.e. avoid things such as /a/b/../c)
  170.                (chdir val)
  171.                (set! val (getcwd))
  172.                (chdir cur)))
  173.             (slot-set! fb 'value val)
  174.             (scan-directory fb val))
  175.           (invoke fb))))))
  176.     ;;
  177.     ;; complete-file
  178.     ;;
  179.     (define (complete-file fb)
  180.       (let ((val (sort (glob (& (value fb) "*")) string<?)))
  181.     (when (= (length val) 1)
  182.         (let ((f (car val)))
  183.           (if (file-is-directory? f) (set! f (& f "/")))
  184.           (slot-set! fb 'value f)
  185.           (scan-directory fb f))))
  186.       ;; Keep focus on the labeled entry widget
  187.       'break)
  188.   
  189.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.     ;; STk:associate-binding starts here
  191.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192.   
  193.     ;;Display current directory in the labeled entry
  194.     (slot-set! self 'value (getcwd))
  195.     
  196.     ;; All files button
  197.     (slot-set! (all-button-of self) 'command (lambda () (toggle-all-files self)))
  198.     
  199.     ;; Help button
  200.     (slot-set! (help-button-of self) 'command 
  201.            (lambda ()
  202.          (STk:show-help-file "fbox-hlp.html")))
  203.     
  204.     ;; Button release in paned
  205.     (bind (listbox-of (left-frame-of self)) "<Double-1>" (lambda () 
  206.                                (choose-parent self)))
  207.     (bind (listbox-of (right-frame-of self)) "<Double-1>" (lambda ()
  208.                                 (choose-file self)))
  209.     
  210.     ;; Tab in the entry
  211.     (bind (entry-of (lentry-of self)) "<space>" (lambda () (complete-file self)))
  212.     (bind (entry-of (lentry-of self)) "<Tab>"   (lambda () (complete-file self)))
  213.     
  214.     ;; Return in the entry
  215.     (bind (entry-of (lentry-of self)) "<Return>" (lambda () (invoke self)))))
  216.  
  217. ;;;
  218. ;;; invoke
  219. ;;;
  220. (define-method invoke ((self <File-box>))
  221.   (invoke (ok-button-of self)))
  222.  
  223. ;;
  224. ;; Directory listing
  225. ;;
  226. (define-method scan-directory ((fb <File-box>) directory)
  227.   (let ((& string-append))
  228.     (when (file-is-directory? directory)
  229.     (let ((files (if (value (all-button-of fb))
  230.              (glob (& directory "/*") (& directory "/.*"))
  231.              (glob (& directory "/*")))))
  232.       ;; Display the right part
  233.       (delete (right-frame-of fb) 0 'end)
  234.       (apply insert (right-frame-of fb) 0 
  235.          (map (lambda (x) (basename x)) (sort files string<?)))
  236.       
  237.       ;; Display the left part
  238.       (delete (left-frame-of fb) 0 'end)
  239.       (apply insert (left-frame-of fb) 0 (decompose-file-name directory))))))
  240.  
  241.  
  242. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  243. ;;;;
  244. ;;;; make-file-box
  245. ;;;;        User function which permits to create a toplevel containing a 
  246. ;;;;        file selection box. Result is the value of the file choosen
  247. ;;;;        or #f if the CANCEL button has been depressed
  248. ;;;;
  249. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  250.  
  251. (define stk:filebox-lock   #F)  ;; lock variable
  252.  
  253. (define (make-file-box . title)
  254.  
  255.   (define (file-box-value fb)
  256.     (let* ((lb  (right-frame-of fb))
  257.        (sel (current-selection lb))
  258.        (val (value fb)))
  259.       (if (file-is-directory? val)
  260.       (string-append val (if sel (string-append "/" (get lb (car sel))) ""))
  261.       val)))
  262.  
  263.   (let* ((t   (make <Toplevel> :class "FileSelector" 
  264.             :title (if (null? title) "File Selection" (car title))))
  265.      (f   (make <File-Box> :parent t))
  266.      (res #t))
  267.  
  268.     ;; map the filebox
  269.     (pack f :expand #t :fill "both")
  270.  
  271.     ;; Associate actions to Ok and Cancel button
  272.     (set! (command (ok-button-of f)) 
  273.       (lambda ()
  274.         (set! res (file-box-value f))
  275.         (set! stk:filebox-lock 'ok)))
  276.     (set! (command (cancel-button-of f)) 
  277.       (lambda ()
  278.         (set! res #f)
  279.         (set! stk:filebox-lock 'cancel)))
  280.  
  281.     (bind t "<Destroy>" (lambda () (set! stk:filebox-lock 'destroy)))
  282.  
  283.     ;; and now wait an event
  284.     (tkwait 'variable 'stk:filebox-lock)
  285.  
  286.     ;; Destroy the window
  287.     (catch (destroy t))
  288.  
  289.     ;; Return the value of res
  290.     res))
  291.  
  292.  
  293. (provide "Filebox")
  294.