"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/tcl/src/NVR_BWidgets/bitmap.tcl" (10 Apr 2007, 2659 Bytes) of package /linux/www/old/Pansophica-src-1.3-1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "bitmap.tcl" see the Fossies "Dox" file reference documentation.

    1 # ------------------------------------------------------------------------------
    2 #  bitmap.tcl
    3 #  This file is part of Unifix BWidget Toolkit
    4 #  $Id: bitmap.tcl,v 1.1.1.1 1999/08/26 18:56:41 dean Exp $
    5 # ------------------------------------------------------------------------------
    6 #  Index of commands:
    7 #     - Bitmap::get
    8 #     - Bitmap::_init
    9 # ------------------------------------------------------------------------------
   10 namespace eval Bitmap {
   11     variable path
   12     variable _bmp
   13     variable _types {
   14         photo  .gif
   15         photo  .ppm
   16         bitmap .xbm
   17         photo  .xpm
   18     }
   19 
   20     proc use {} {}
   21 }
   22 
   23 
   24 # ------------------------------------------------------------------------------
   25 #  Command Bitmap::get
   26 # ------------------------------------------------------------------------------
   27 proc Bitmap::get { name } {
   28     variable path
   29     variable _bmp
   30     variable _types
   31 
   32     if {[info exists _bmp($name)]} {
   33         return $_bmp($name)
   34     }
   35 
   36     # --- Nom de fichier avec extension ------------------------------------------------------
   37     set ext [file extension $name]
   38     if { $ext != "" } {
   39         if { ![info exists _bmp($ext)] } {
   40             error "$ext not supported"
   41         }
   42 
   43         if { [file exists $name] } {
   44             if {![string compare $ext ".xpm"]} {
   45                 set _bmp($name) [xpm-to-image $name]
   46                 return $_bmp($name)
   47             }
   48             if {![catch {set _bmp($name) [image create $_bmp($ext) -file $name]}]} {
   49                 return $_bmp($name)
   50             }
   51         }
   52     }
   53 
   54     foreach dir $path {
   55         foreach {type ext} $_types {
   56             if { [file exists [file join $dir $name$ext]] } {
   57                 if {![string compare $ext ".xpm"]} {
   58                     set _bmp($name) [xpm-to-image [file join $dir $name$ext]]
   59                     return $_bmp($name)
   60                 } else {
   61                     if {![catch {set _bmp($name) [image create $type -file [file join $dir $name$ext]]}]} {
   62                         return $_bmp($name)
   63                     }
   64                 }
   65             }
   66         }
   67     }
   68 
   69     return -code error "$name not found"
   70 }
   71 
   72 
   73 # ------------------------------------------------------------------------------
   74 #  Command Bitmap::_init
   75 # ------------------------------------------------------------------------------
   76 proc Bitmap::_init { } {
   77     global   env
   78     variable path
   79     variable _bmp
   80     variable _types
   81 
   82     set path [list "." [file join $env(BWIDGET_LIBRARY) images]]
   83     set supp [image types]
   84     foreach {type ext} $_types {
   85         if { [lsearch $supp $type] != -1} {
   86             set _bmp($ext) $type
   87         }
   88     }
   89 }
   90 
   91 
   92 Bitmap::_init