home *** CD-ROM | disk | FTP | other *** search
/ Freelog Special Freeware 31 / FreelogHS31.iso / Texte / scribus / scribus-1.3.3.9-win32-install.exe / tcl / tix8.1 / Tix.tcl < prev    next >
Text File  |  2002-01-24  |  13KB  |  500 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Tix.tcl,v 1.5.2.4 2002/01/24 10:08:58 idiscovery Exp $
  4. #
  5. # Tix.tcl --
  6. #
  7. #    This file implements the Tix application context class
  8. #
  9. # Copyright (c) 1993-1999 Ioi Kim Lam.
  10. # Copyright (c) 2000-2001 Tix Project Group.
  11. #
  12. # See the file "license.terms" for information on usage and redistribution
  13. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14. #
  15.  
  16. if 0 {
  17. proc tix {} {
  18.     # dummy proc. make sure the entry "tix" is in the tclIndex file
  19.     #
  20. }
  21. }
  22.  
  23. tixClass tixAppContext {
  24.     -superclass {}
  25.     -classname  TixAppContext
  26.     -method {
  27.     cget configure addbitmapdir filedialog getbitmap getimage
  28.     option platform resetoptions setbitmap
  29.     }
  30.     -flag {
  31.     -binding -debug -extracmdargs -filedialog -fontset -grabmode
  32.     -haspixmap -libdir -scheme -schemepriority -percentsubst
  33.     }
  34.     -readonly {
  35.     -haspixmap
  36.     }
  37.     -configspec {
  38.     {-binding            TK}
  39.     {-debug              0}
  40.     {-extracmdargs         1}
  41.     {-filedialog        ""}
  42.     {-fontset            WmDefault}
  43.     {-grabmode         global}
  44.     {-haspixmap         0}
  45.     {-libdir             ""}
  46.     {-percentsubst        0}
  47.     {-scheme             WmDefault}
  48.     {-schemepriority         21}
  49.     }
  50.     -alias {
  51.     }
  52. }
  53.  
  54. proc tixAppContext:Constructor {w} {
  55.     upvar #0 $w data
  56.     global tix_priv env argv0 tixPriv
  57.     global tix_library tixOption tcl_platform
  58.  
  59.     if {[info exists tcl_platform] && $tcl_platform(platform) == "windows"} {
  60.     regsub -all "/" $tix_library \\ tix_library
  61.     }
  62.  
  63.     if {[info exists data(initialized)]} {
  64.     error "tixAppContext has already be initialized"
  65.     } else {
  66.     set data(initialized) 1
  67.     }
  68.  
  69.     if {[tixStrEq $tix_library ""]} {
  70.     set data(et) 1
  71.     } else {
  72.     set data(et) 0
  73.     }
  74.     set data(image) 0
  75.  
  76.     # These options were set when tixwish started up
  77.     #
  78.     set data(-binding)        $tix_priv(-binding)
  79.     set data(-debug)        $tix_priv(-debug)
  80.     set data(-fontset)        $tix_priv(-fontset)
  81.     set data(-scheme)        $tix_priv(-scheme)
  82.     set data(-schemepriority)    $tix_priv(-schemepriority)
  83.  
  84.     if {![info exists tix_priv(isSafe)]} {
  85.     set data(-libdir)    [tixFSAbsPath $tix_library]
  86.     }
  87.     set tixOption(prioLevel) $tix_priv(-schemepriority)
  88.  
  89.     # Enable/Disable Intrinsics debugging
  90.     #
  91.     if {$data(-debug) != "0"} {
  92.     set tix_priv(debug) $data(-debug)
  93.     } else {
  94.     set tix_priv(debug) 0
  95.     }
  96.  
  97.     if {![info exists tix_priv(isSafe)]} {
  98.     tixAppContext:config-fontset $w $data(-fontset)
  99.     tixAppContext:config-scheme  $w $data(-scheme)
  100.     }
  101.  
  102.     tixAppContext:BitmapInit $w
  103.     tixAppContext:FileDialogInit $w
  104.  
  105.     # Force the "." window to accept the new Tix options
  106.     #
  107.     foreach spec [. configure] {
  108.     if {[llength $spec] > 2} {
  109.         set flag  [lindex $spec 0]
  110.         set name  [lindex $spec 1]
  111.         set class [lindex $spec 2]
  112.         set value [option get . $name $class]
  113.         catch {. config $flag $value}
  114.     }
  115.     }
  116.     # Clean up any error message generated by the above loop
  117.     catch {uplevel #0 set errorInfo \"\"}
  118.  
  119. }
  120.  
  121. #----------------------------------------------------------------------
  122. #  Configurations
  123. #
  124. #----------------------------------------------------------------------
  125. proc tixAppContext:resetoptions {w scheme fontset {schemePrio ""}} {
  126.     upvar #0 $w data
  127.  
  128.     if {! $data(et)} {
  129.     global tixOption
  130.     option clear
  131.  
  132.     if {$schemePrio != ""} {
  133.         set tixOption(prioLevel) $schemePrio
  134.     }
  135.     tixAppContext:config-scheme  $w $scheme
  136.     tixAppContext:config-fontset $w $fontset
  137.     }
  138. }
  139. proc tixAppContext:StartupError {args} {
  140.  
  141.     bgerror [join $args "\n"]
  142. }
  143.  
  144. proc tixAppContext:config-fontset {w value} {
  145.     upvar #0 $w data
  146.     global tix_priv tixOption
  147.  
  148.     set data(-fontset) $value
  149.  
  150.     #-----------------------------------
  151.     # Initialization of options database
  152.     #-----------------------------------
  153.     # Load the fontset
  154.     #
  155.     if {!$data(et)} {
  156.         set prefDir [file join $data(-libdir) pref]
  157.         set fontSetFile [file join $prefDir $data(-fontset).fsc]
  158.     if {[file exists $fontSetFile]} {
  159.         source $fontSetFile
  160.         tixPref:InitFontSet:$data(-fontset)
  161.         tixAppContext:CheckFontSets $w
  162.         tixPref:SetFontSet:$data(-fontset)
  163.     } else {
  164.         tixAppContext:StartupError \
  165.         "    Error: cannot use fontset \"$data(-fontset)\"" \
  166.         "       Using default fontset "
  167.         tixSetDefaultFontset
  168.         tixAppContext:CheckFontSets $w
  169.     }
  170.     } else {
  171.     if [catch {
  172.         tixPref:InitFontSet:$data(-fontset)
  173.         tixAppContext:CheckFontSets $w
  174.         tixPref:SetFontSet:$data(-fontset)
  175.     }] {
  176.         # User chose non-existent fontset
  177.         #
  178.         tixAppContext:StartupError \
  179.         "    Error: cannot use fontset \"$data(-fontset)\"" \
  180.         "       Using default fontset "
  181.         tixSetDefaultFontset
  182.         tixAppContext:CheckFontSets $w
  183.     }
  184.     }
  185.  
  186.     # Compatibility stuff: the obsolete name courier_font has been changed to
  187.     # fixed_font
  188.     set tixOption(courier_font) $tixOption(fixed_font)
  189. }
  190.  
  191. proc tixAppContext:config-scheme {w value} {
  192.     upvar #0 $w data
  193.     global tix_priv
  194.  
  195.     set data(-scheme) $value
  196.  
  197.     # Load the color scheme
  198.     #
  199.     if {!$data(et)} {
  200.     set schemeName [file join [file join $data(-libdir) pref] \
  201.         $data(-scheme).csc]
  202.     if {[file exists $schemeName]} {
  203.         source $schemeName
  204.         if {[winfo depth .] >= 8} {
  205.         tixPref:SetScheme-Color:$data(-scheme)
  206.         } else {
  207.         tixPref:SetScheme-Mono:$data(-scheme)
  208.         }
  209.     } else {
  210.         tixAppContext:StartupError \
  211.         "    Error: cannot use color scheme \"$data(-scheme)\"" \
  212.         "       Using default color scheme"
  213.         if {[winfo depth .] >= 8} {
  214.         tixSetDefaultScheme-Color
  215.         } else {
  216.         tixSetDefaultScheme-Mono
  217.         }
  218.     }
  219.     } else {
  220.     if [catch {
  221.         if {[winfo depth .] >= 8} {
  222.         tixPref:SetScheme-Color:$data(-scheme)
  223.         } else {
  224.         tixPref:SetScheme-Mono:$data(-scheme)
  225.         }
  226.     }] {
  227.         # User chose non-existent color scheme
  228.         #
  229.         tixAppContext:StartupError \
  230.         "    Error: cannot use color scheme \"$data(-scheme)\"" \
  231.         "       Using default color scheme"
  232.         if {[winfo depth .] >= 8} {
  233.         tixSetDefaultScheme-Color
  234.         } else {
  235.         tixSetDefaultScheme-Mono
  236.         }
  237.     }
  238.     }
  239. }
  240.  
  241. #----------------------------------------------------------------------
  242. #  Private methods
  243. #
  244. #----------------------------------------------------------------------
  245. proc tixAppContext:BitmapInit {w} {
  246.     upvar #0 $w data
  247.  
  248.     # See whether we have pixmap extension
  249.     #
  250.     set data(-haspixmap) true
  251.  
  252.     # Dynamically set the bitmap directory
  253.     #
  254.     if {! $data(et)} {
  255.     set data(bitmapdirs) [list [file join $data(-libdir) bitmaps]]
  256.     } else {
  257.     set data(bitmapdirs) ""
  258.     }
  259. }
  260.  
  261. proc tixAppContext:FileDialogInit {w} {
  262.     upvar #0 $w data
  263.  
  264.     if {$data(-filedialog) == ""} {
  265.     set data(-filedialog) [option get . fileDialog FileDialog]
  266.     }
  267.     if {$data(-filedialog) == ""} {
  268.     set data(-filedialog) tixFileSelectDialog
  269.     }
  270. }
  271.  
  272. #----------------------------------------------------------------------
  273. # If a font in the fontset is not available, use a default fontset.
  274. #
  275. proc tixAppContext:CheckFontSets  {w} {
  276.     upvar #0 $w data
  277.     global tixOption tcl_version
  278.  
  279.     if {$tcl_version >= "8.0"} {
  280.     # fonts will never fail ..
  281.     return
  282.     }
  283.  
  284.     set default_font "fixed"
  285.     set options {font bold_font menu_font italic_font fixed_font}
  286.  
  287.     if {[winfo exists .tix-xxx-test]} {
  288.     destroy .tix-xxx-test
  289.     }
  290.     set lab [label .tix-xxx-test]
  291.     foreach opt $options {
  292.     if {[catch {$lab config -font $tixOption($opt)}]} {
  293.         tixAppContext:StartupError \
  294.         "    Error: cannot use font \"$tixOption($opt)\" as \"$opt\"" \
  295.         "       using \"$default_font\" instead"
  296.         set tixOption($opt) $default_font
  297.     }
  298.     }
  299.     destroy $lab
  300. }
  301.  
  302. #----------------------------------------------------------------------
  303. #     Public methods
  304. #----------------------------------------------------------------------
  305. proc tixAppContext:addbitmapdir {w bmpdir} {
  306.     upvar #0 $w data
  307.  
  308.     if {[lsearch $data(bitmapdirs) $bmpdir] == "-1"} {
  309.     lappend data(bitmapdirs) $bmpdir 
  310.     }
  311. }
  312.  
  313. proc tixAppContext:getimage {w name} {
  314.     upvar #0 $w data
  315.     global tixPriv tix_priv
  316.  
  317.     if {[info exists data(img:$name)]} {
  318.     return $data(img:$name)
  319.     }
  320.  
  321.     if {![info exists tix_priv(isSafe)]} {
  322.     foreach dir $data(bitmapdirs) {
  323.         if {[file exists [file join $dir $name.xpm]]} {
  324.         if {![catch {
  325.             set img tiximage$data(image)
  326.             set data(img:$name) \
  327.             [image create pixmap $img -file [file join $dir $name.xpm]]
  328.         }]} {
  329.             incr data(image) 
  330.             break
  331.         }
  332.         }
  333.         if {[file exists [file join $dir $name.gif]]} {
  334.         if {![catch {
  335.             set img tiximage$data(image)
  336.             set data(img:$name) \
  337.                 [image create photo $img -file [file join $dir $name.gif]]
  338.         }]} {
  339.             incr data(image) 
  340.             break
  341.         }
  342.         }
  343.         if {[file exists [file join $dir $name.ppm]]} {
  344.         if {![catch {
  345.             set img tiximage$data(image)
  346.             set data(img:$name) \
  347.                 [image create photo $img -file [file join $dir $name.ppm]]
  348.         }]} {
  349.             incr data(image) 
  350.             break
  351.         }
  352.         }
  353.         if {[file exists [file join $dir $name.xbm]]} {
  354.         if {![catch {
  355.             set img tiximage$data(image)
  356.             set data(img:$name) \
  357.                 [image create bitmap $img -file [file join $dir $name.xbm]]
  358.         }]} {
  359.             incr data(image) 
  360.             break
  361.         }
  362.         }
  363.         if {[file exists [file join $dir $name]]} {
  364.         if {![catch {
  365.             set img tiximage$data(image)
  366.             set data(img:$name) \
  367.                 [image create bitmap $img -file [file join $dir $name]]
  368.         }]} {
  369.             incr data(image) 
  370.             break
  371.         }
  372.         }
  373.     }
  374.     }
  375.  
  376.     if {![info exists data(img:$name)]} {
  377.     catch {
  378.         set img tiximage$data(image)
  379.         # This is for compiled-in images
  380.         set data(img:$name) [image create pixmap $img -id $name]
  381.     } err
  382.     if {[string match internal* $err]} {
  383.         error $err
  384.     } else {
  385.         incr data(image) 
  386.     }
  387.     }
  388.  
  389.     if {[info exists data(img:$name)]} {
  390.     return $data(img:$name)
  391.     } else {
  392.     error "image file \"$name\" cannot be found"
  393.     }
  394. }
  395.  
  396.  
  397. proc tixAppContext:getbitmap {w bitmapname} {
  398.     upvar #0 $w data
  399.     global tix_priv
  400.  
  401.     if {[info exists data(bmp:$bitmapname)]} {
  402.     return $data(bmp:$bitmapname)
  403.     } else {
  404.     set ext [file extension $bitmapname]
  405.     if {$ext == ""} {
  406.         set ext .xbm
  407.     }
  408.  
  409.     # This is the fallback value. If we can't find the bitmap in
  410.     # the bitmap directories, then use the name of the bitmap
  411.     # as the default value.
  412.     #
  413.     set data(bmp:$bitmapname) $bitmapname
  414.  
  415.     if {[info exists tix_priv(isSafe)]} {
  416.         return $data(bmp:$bitmapname)
  417.     }
  418.  
  419.     foreach dir $data(bitmapdirs) {
  420.         case $ext {
  421.         .xbm {
  422.             if {[file exists [file join $dir $bitmapname.xbm]]} {
  423.             set data(bmp:$bitmapname) \
  424.                 @[file join $dir $bitmapname.xbm]
  425.             break
  426.             }
  427.             if {[file exists [file join $dir $bitmapname]]} {
  428.             set data(bmp:$bitmapname) @[file join $dir $bitmapname]
  429.             break
  430.             }
  431.         }
  432.         default {
  433.             if {[file exists [file join $dir $bitmapname]]} {
  434.             set data(bmp:$bitmapname) @[file join $dir $bitmapname]
  435.             break
  436.             }
  437.         }
  438.         }
  439.     }
  440.  
  441.     return $data(bmp:$bitmapname)
  442.     }
  443. }
  444.  
  445. proc tixAppContext:filedialog {w {type tixFileSelectDialog}} {
  446.     upvar #0 $w data
  447.  
  448.     if {$type == ""} {
  449.     set type $data(-filedialog)
  450.     }
  451.     if {![info exists data(filedialog,$type)]} {
  452.     set data(filedialog,$type) ""
  453.     }
  454.  
  455.     if {$data(filedialog,$type) == "" || \
  456.         ![winfo exists $data(filedialog,$type)]} {
  457.     set data(filedialog,$type) [$type .tixapp_filedialog_$type]
  458.     }
  459.  
  460.     return $data(filedialog,$type)
  461. }
  462.  
  463. proc tixAppContext:option {w action {option ""} {value ""}} {
  464.     global tixOption
  465.  
  466.     if {$action == "get"} {
  467.     if {$option == ""} {return [lsort [array names tixOption]]}
  468.     return $tixOption($option)
  469.     }
  470. }
  471.  
  472. proc tixAppContext:platform {w} {
  473.     global tcl_platform
  474.  
  475.     return $tcl_platform(platform)
  476. }
  477.  
  478. proc tixDebug {message {level "1"}} {
  479.  
  480.     if {[tix cget -debug] == "" || [tix cget -debug] == "0"} {return}
  481.  
  482.     if {[set debug [tix cget -debug]] > 0} {
  483.     # use $level here
  484.     if {[info commands console] != ""} {
  485.         console eval [list .console insert end "$str\n"]
  486.     } elseif {[catch {fconfigure stderr}]} {
  487.         # This will happen under PYTHONW.EXE or frozen Windows apps
  488.         proc tixDebug args {} 
  489.     } else {
  490.         puts stderr $message
  491.     }
  492.     }
  493. }
  494.  
  495. if {[tixStrEq [info command toplevel] ""]} {
  496.     proc toplevel {args} {
  497.     return eval frame $args
  498.     }
  499. }
  500.