home *** CD-ROM | disk | FTP | other *** search
/ Practical Programming in Tcl & Tk (4th Edition) / TCLBOOK4.BIN / pc / exsource.old / 19_9.tcl < prev    next >
Text File  |  2003-04-15  |  2KB  |  83 lines
  1. #
  2. # Example 19-9
  3. # The Tempfile security policy.
  4. #
  5.  
  6. # Policy parameters:
  7. #     directory is the location for the files
  8. #     maxfile is the number of files allowed in the directory
  9. #     maxsize is the max size for any single file.
  10.  
  11. array set tempfile {
  12.     maxfile                4
  13.     maxsize                65536
  14. }
  15. # tempfile(directory) is computed dynamically based on
  16. # the source of the script
  17.  
  18. proc Tempfile_PolicyInit {slave} {
  19.     global tempfile                
  20.     interp alias $slave open {} \
  21.         TempfileOpenAlias $slave $tempfile(directory) \
  22.             $tempfile(maxfile)
  23.     interp alias $slave puts {} TempfilePutsAlias $slave \
  24.         $tempfile(maxsize)
  25.     interp alias $slave exit {} TempfileExitAlias $slave
  26. }
  27. proc TempfileOpenAlias {slave dir maxfile name {m r} {p 0777}} {
  28.     global tempfile
  29.     # remove sneaky characters
  30.     regsub -all {|/:} [file tail $name] {} real
  31.     set real [file join $dir $real]
  32.     # Limit the number of files
  33.     set files [glob -nocomplain [file join $dir *]]
  34.     set N [llength $files]
  35.     if {($N >= $maxfile) && (\
  36.             [lsearch -exact $files $real] < 0)} {
  37.         error "permission denied"
  38.     }
  39.     if [catch {open $real $m $p} out] {
  40.         return -code error "$name: permission denied"
  41.     }
  42.     lappend tempfile(channels,$slave) $out
  43.     interp share {} $out $slave
  44.     return $out
  45. }
  46. proc TempfileExitAlias {slave} {
  47.     global tempfile
  48.     interp delete $slave
  49.     if [info exists tempfile(channels,$slave)] {
  50.         foreach out $tempfile(channels,$slave) {
  51.             catch {close $out}
  52.         }
  53.         unset tempfile(channels,$slave)
  54.     }
  55. }
  56. # See also the puts alias in Example 23-4 on page 359
  57. proc TempfilePutsAlias {slave max chan args} {
  58.     # max is the file size limit, in bytes
  59.     # chan is the I/O channel
  60.     # args is either a single string argument,
  61.     # or the -nonewline flag plus the string.
  62.  
  63.     if {[llength $args] > 2} {
  64.         error "invalid arguments"
  65.     }
  66.     if {[llength $args] == 2} {
  67.         if {![string match -n* [lindex $argv 0]]} {
  68.             error "invalid arguments"
  69.         }
  70.         set string [lindex $args 1]
  71.     } else {
  72.         set string [lindex $args 0]\n
  73.     }
  74.     set size [expr [tell $chan] + [string length $string]]
  75.     if {$size > $max} {
  76.         error "File size exceeded"
  77.     } else {
  78.         puts -nonewline $chan $string
  79.     }
  80. }
  81.  
  82.  
  83.