tcl/objects.tcl

   1 #
   2 # objects.tcl
   3 # some common procedures to implement fGIS objects
   4 # This file is part of fGIS
   5 #
   6
   7
   8 #
   9 # generates new unique name which starts with prefix.
  10 # first name, which is not name of existing Tcl command and
  11 #  for which test script returns 1 would be returned
  12 #
  13 proc fgisMakeObjectName {prefix {test "info exists"}} {
  14 set i 0
  15 while 1 {
  16   set name $prefix$i
  17   if {![string length [info command $prefix$i]]&&
  18                ![uplevel #0 $test $prefix$i]} {
  19      return $prefix$i
  20   }
  21   incr i
  22 }
  23 }
  24 #
  25 # returns 1 if name can be used for creation of new object
  26 #
  27 proc fgisCheckName {name {test "info exists"}} {
  28  expr ![string length [info command $name]]&&![uplevel #0 $test $name]
  29 }
  30
  31 #
  32 # Sets given variable to object value, if passed value is valid command
  33 # name.
  34 # Second argument specifies, how to deal with empty value.
  35 # none - means unset variable
  36 # nodefault - raise error
  37 # any other value is substituted instead of empty string
  38 # This procedure DELETES object, stored in var previously, if it is
  39 # not eqial to default
  40 #
  41
  42 proc fgisSetObj {var default value} {
  43   # first, check if we need to substitute defaults
  44   if [string match {} $value] {
  45       switch -exact -- $default {
  46          none {
  47                if {[uplevel info exists $var]&&
  48                             "[uplevel set $var]"!="$default"} {
  49                   [uplevel set $var] delete
  50                }
  51              uplevel unset $var
  52              return
  53          }
  54          nodefault {
  55              return -code error -errorcode [list BADVALUE $var] \
  56                  "Empty value not allowed"
  57          }
  58          default {
  59              set value $default
  60          }
  61       }
  62    } else {
  63        # check if passed value is valid object. Defaults are
  64        # not subject to check - programmer knows, but user knows not
  65        if [llength [info command $value]]!=1 {
  66           return -code error -errorcode [list BADVALUE $var] \
  67                "Invalid object \"$value\""
  68        }
  69    }
  70    if {[uplevel info exists $var]&&"[uplevel set $var]"!="$default"} {
  71       [uplevel set $var] delete
  72    }
  73    uplevel set $var [list $value]
  74    return
  75 }
  76
  77 #
  78 # fgisSetList - sets given variable to value, if value is
  79 # one from given list. Otherwise rises error
  80 #
  81 proc fgisSetList {var list value} {
  82   if [checklistopt value $list msg] {
  83       return -code error -errorcode [list BADVALUE $var] $msg
  84   }
  85   uplevel set $var [list $value]
  86   return
  87 }