home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource / 19_10.tcl < prev    next >
Text File  |  2003-04-16  |  2KB  |  61 lines
  1. #
  2. # Example 19-10
  3. # Restricted puts using hidden commands.
  4. #
  5.  
  6. proc Tempfile_PolicyInit {slave} {
  7.     global tempfile                
  8.     interp alias $slave open {} \
  9.         TempfileOpenAlias $slave $tempfile(directory) \
  10.             $tempfile(maxfile)
  11.     interp hide $slave tell
  12.     interp alias $slave tell {} TempfileTellAlias $slave
  13.     interp hide $slave puts
  14.     interp alias $slave puts {} TempfilePutsAlias $slave \
  15.         $tempfile(maxsize)
  16.     # no special exit alias required
  17. }
  18. proc TempfileOpenAlias {slave dir maxfile name {m r} {p 0777}} {
  19.     # remove sneaky characters
  20.     regsub -all {|/:} [file tail $name] {} real
  21.     set real [file join $dir $real]
  22.     # Limit the number of files
  23.     set files [glob -nocomplain [file join $dir *]]
  24.     set N [llength $files]
  25.     if {($N >= $maxfile) && (\
  26.             [lsearch -exact $files $real] < 0)} {
  27.         error "permission denied"
  28.     }
  29.     if [catch {interp invokehidden $slave \
  30.             open $real $m $p} out] {
  31.         return -code error "$name: permission denied"
  32.     }
  33.     return $out
  34. }
  35. proc TempfileTellAlias {slave chan} {
  36.     interp invokehidden $slave tell $chan
  37. }
  38. proc TempfilePutsAlias {slave max chan args} {
  39.     if {[llength $args] > 2} {
  40.         error "invalid arguments"
  41.     }
  42.     if {[llength $args] == 2} {
  43.         if {![string match -n* [lindex $args 0]]} {
  44.             error "invalid arguments"
  45.         }
  46.         set string [lindex $args 1]
  47.     } else {
  48.         set string [lindex $args 0]\n
  49.     }
  50.     set size [interp invokehidden $slave tell $chan]
  51.     incr size [string length $string]
  52.     if {$size > $max} {
  53.         error "File size exceeded"
  54.     } else {
  55.         interp invokehidden $slave \
  56.             puts -nonewline $chan $string
  57.     }
  58. }
  59.  
  60.  
  61.