scripts/sessionobj.itcl

   1 # vim: ft=tcl foldmarker=<<<,>>>
   2
   3 class tlc::Sessionobj {
   4         constructor {args} {}
   5         destructor      {}
   6
   7         public  {
   8                 variable        client_ip               ""
   9                 variable        sessionkey
  10                 variable        timeout                 1200                    set_timeout ;# the length of time, in seconds, for which this session is valid
  11                 variable        delete_when_empty 1     ;# determines whether setting a var to "" removes it, like a web session
  12                 method          getvar                  {varname}
  13                 method          setvar                  {varname value}
  14                 method          var_exists              {varname}
  15                 method          dump                    {}
  16         }
  17         private {
  18                 variable        sessionvars
  19                 variable        last_access
  20                 variable        timerid                 ""
  21
  22                 method          update_access   {}
  23                 method          set_timeout             {{newval ""}}
  24                 method          delete_var              {varname}
  25         }
  26 }
  27
  28 body tlc::Sessionobj::constructor {args} { #<<<1
  29         eval configure $args
  30         log notice "connecting ip is: $client_ip"
  31         set sessionkey "${client_ip}[clock clicks]"
  32         while {[info exists tlc::sessions($sessionkey)]} {
  33                 set sessionkey "${client_ip}[clock clicks]"
  34         }
  35         update_access
  36         return $sessionkey
  37 }
  38
  39 body tlc::Sessionobj::getvar {varname} { #<<<1
  40         if {[info exists sessionvars($varname)]} {
  41                 return $sessionvars($varname)
  42         } else {
  43                 return ""
  44         }
  45 }
  46
  47 body tlc::Sessionobj::setvar {varname value} { #<<<1
  48         if {$value=="" && $delete_when_empty} {
  49                 delete_var $varname
  50         } else {
  51                 set sessionvars($varname) $value
  52         }
  53         return 1
  54 }
  55
  56 body tlc::Sessionobj::var_exists {varname} { #<<<1
  57         return [info exists sessionvars($varname)]
  58 }
  59
  60 body tlc::Sessionobj::update_access {} { #<<<1
  61         after cancel $timerid
  62         set timerid [after [expr {$timeout*1000}] [code $this destructor]]
  63 #       set last_access [clock seconds]
  64 }
  65
  66 body tlc::Sessionobj::set_timeout {{newval ""}} { #<<<1
  67         update_access
  68         if {$newval == ""} {set newval $timeout}
  69         if {[string is double -strict $newval]} {
  70                 set timeout $newval
  71         } else {
  72                 set num [string range [expr [string length $newval]-1] end]
  73                 if {[string is double -strict $num]} {
  74                         switch -- [string range $newval end end] {
  75                                 "h" {set timeout [expr {$newval*3600000}]}
  76                                 "m"     {set timeout [expr {$newval*60000}]}
  77                                 "s" {set timeout [expr {$num*1000}]}
  78                                 default {
  79                                                         log error "Unable to set session lifetime to requested value of\"$newval\".\
  80                                                                 Value not understood."
  81                                                         return 0
  82                                                 }
  83                         }
  84                 } else {
  85                         log error "Unable to set session lifetime to requested value of\"$newval\". Value not understood."
  86                         return 0
  87                 }
  88         }
  89         return 1
  90 }
  91
  92 body tlc::Sessionobj::delete_var {varname} { #<<<1
  93         if {[info exists sessionvars(varname)]} {
  94                 foreach {idx val} [array get sessionvars] {
  95                         if {$idx != $varname} {
  96                                 set new_vars($idx) $val
  97                         }
  98                 }
  99                 array unset sessionvars
 100                 array set sessionvars [array get new_vars]
 101         } else {
 102                 return 1        ;# although the function wasn't successful in the correct sense of the word, the described
 103 #                                               var doesn't exist -- the net result is the same as deleting it
 104         }
 105 }
 106
 107 body tlc::Sessionobj::dump {} { #<<<1
 108         return [array get sessionvars]
 109 }
 110
 111 body tlc::Sessionobj::destructor {} { #<<<1
 112         log notice "Session object ($sessionkey) is dying due to timeout."
 113 }