/[emacs]/emacs/lisp/tree-widget.el
ViewVC logotype

Diff of /emacs/lisp/tree-widget.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by dpe, Thu Sep 22 09:54:54 2005 UTC revision 1.12 by dpe, Fri Sep 30 06:28:53 2005 UTC
# Line 131  Line 131 
131    :type  'boolean    :type  'boolean
132    :group 'tree-widget)    :group 'tree-widget)
133    
134    (defvar tree-widget-themes-load-path
135      '(load-path
136        (let ((dir (if (fboundp 'locate-data-directory)
137                       (locate-data-directory "tree-widget") ;; XEmacs
138                     data-directory)))
139          (and dir (list dir (expand-file-name "images" dir))))
140        )
141      "List of locations where to search for the themes sub-directory.
142    Each element is an expression that will be evaluated to return a
143    single directory or a list of directories to search.
144    
145    The default is to search in the `load-path' first, then in the
146    \"images\" sub directory in the data directory, then in the data
147    directory.
148    The data directory is the value of the variable `data-directory' on
149    Emacs, and what `(locate-data-directory \"tree-widget\")' returns on
150    XEmacs.")
151    
152  (defcustom tree-widget-themes-directory "tree-widget"  (defcustom tree-widget-themes-directory "tree-widget"
153    "*Name of the directory where to look up for image themes.    "*Name of the directory where to look up for image themes.
154  When nil use the directory where the tree-widget library is located.  When nil use the directory where the tree-widget library is located.
155  When a relative name is specified, try to locate that sub directory in  When a relative name is specified, try to locate that sub directory in
156  `load-path', then in the data directory, and use the first one found.  the locations specified in `tree-widget-themes-load-path'.
 The data directory is the value of the variable `data-directory' on  
 Emacs, and what `(locate-data-directory \"tree-widget\")' returns on  
 XEmacs.  
157  The default is to use the \"tree-widget\" relative name."  The default is to use the \"tree-widget\" relative name."
158    :type '(choice (const :tag "Default" "tree-widget")    :type '(choice (const :tag "Default" "tree-widget")
159                   (const :tag "With the library" nil)                   (const :tag "With the library" nil)
# Line 236  Give the image the specified properties Line 251  Give the image the specified properties
251        (apply 'create-image `(,file ,type nil ,@props)))        (apply 'create-image `(,file ,type nil ,@props)))
252      (defsubst tree-widget-image-formats ()      (defsubst tree-widget-image-formats ()
253        "Return the alist of image formats/file name extensions.        "Return the alist of image formats/file name extensions.
254  See also the option `widget-image-file-name-suffixes'."  See also the option `widget-image-conversion'."
255        (delq nil        (delq nil
256              (mapcar              (mapcar
257               #'(lambda (fmt)               #'(lambda (fmt)
# Line 264  Does nothing if NAME is already the curr Line 279  Does nothing if NAME is already the curr
279           (make-vector 4 nil))           (make-vector 4 nil))
280      (aset tree-widget--theme 0 name)))      (aset tree-widget--theme 0 name)))
281    
282    (defun tree-widget--locate-sub-directory (name path)
283      "Locate the sub-directory NAME in PATH.
284    Return the absolute name of the directory found, or nil if not found."
285      (let (dir elt)
286        (while (and (not dir) (consp path))
287          (setq elt  (condition-case nil (eval (car path)) (error nil))
288                path (cdr path))
289          (cond
290           ((stringp elt)
291            (setq dir (expand-file-name name elt))
292            (or (file-accessible-directory-p dir)
293                (setq dir nil)))
294           ((and elt (not (equal elt (car path))))
295            (setq dir (tree-widget--locate-sub-directory name elt)))))
296        dir))
297    
298  (defun tree-widget-themes-directory ()  (defun tree-widget-themes-directory ()
299    "Locate the directory where to search for a theme.    "Locate the directory where to search for a theme.
300  It is defined in variable `tree-widget-themes-directory'.  It is defined in variable `tree-widget-themes-directory'.
301  Return the absolute name of the directory found, or nil if the  Return the absolute name of the directory found, or nil if the
302  specified directory is not accessible."  specified directory is not accessible."
303    (let ((found (aref tree-widget--theme 1)))    (let ((found (aref tree-widget--theme 1)))
304      (if found      (cond
305          ;; The directory is available in the cache.       ;; The directory was not found.
306          (unless (eq found 'void) found)       ((eq found 'void)
307        (cond        (setq found nil))
308         ;; Use the directory where tree-widget is located.       ;; The directory is available in the cache.
309         ((null tree-widget-themes-directory)       (found)
310          (setq found (locate-library "tree-widget"))       ;; Use the directory where this library is located.
311          (when found       ((null tree-widget-themes-directory)
312            (setq found (file-name-directory found))        (setq found (locate-library "tree-widget"))
313            (or (file-accessible-directory-p found)        (when found
314                (setq found nil))))          (setq found (file-name-directory found))
        ;; Check accessibility of absolute directory name.  
        ((file-name-absolute-p tree-widget-themes-directory)  
         (setq found (expand-file-name tree-widget-themes-directory))  
315          (or (file-accessible-directory-p found)          (or (file-accessible-directory-p found)
316              (setq found nil)))              (setq found nil))))
317         ;; Locate a sub-directory in `load-path' and data directory.       ;; Check accessibility of absolute directory name.
318         (t       ((file-name-absolute-p tree-widget-themes-directory)
319          (let ((path        (setq found (expand-file-name tree-widget-themes-directory))
320                 (append load-path        (or (file-accessible-directory-p found)
321                         (list (if (fboundp 'locate-data-directory)            (setq found nil)))
322                                   ;; XEmacs       ;; Locate a sub-directory in `tree-widget-themes-load-path'.
323                                   (locate-data-directory "tree-widget")       (t
324                                 ;; Emacs        (setq found (tree-widget--locate-sub-directory
325                                 data-directory)))))                     tree-widget-themes-directory
326            (while (and path (not found))                     tree-widget-themes-load-path))))
327              (when (car path)      ;; Store the result in the cache for later use.
328                (setq found (expand-file-name      (aset tree-widget--theme 1 (or found 'void))
329                             tree-widget-themes-directory (car path)))      found))
               (or (file-accessible-directory-p found)  
                   (setq found nil)))  
             (setq path (cdr path))))))  
       ;; Store the result in the cache for later use.  
       (aset tree-widget--theme 1 (or found 'void))  
       found)))  
330    
331  (defsubst tree-widget-set-image-properties (props)  (defsubst tree-widget-set-image-properties (props)
332    "In current theme, set images properties to PROPS."    "In current theme, set images properties to PROPS."
# Line 351  XEmacs in the variables `tree-widget-ima Line 373  XEmacs in the variables `tree-widget-ima
373      plist))      plist))
374    
375  (defconst tree-widget--cursors  (defconst tree-widget--cursors
376    ;; Pointer shapes when the mouse pointer is over tree-widget images.    ;; Pointer shapes when the mouse pointer is over inactive
377    ;; This feature works since Emacs 22, and ignored on older versions,    ;; tree-widget images.  This feature works since Emacs 22, and
378    ;; and XEmacs.    ;; ignored on older versions, and XEmacs.
379    '(    '(
380      ("guide"     . arrow)      ("guide"     . arrow)
381      ("no-guide"  . arrow)      ("no-guide"  . arrow)

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26