#!/ucs/bin/tclsh

# this program changes the permissions on the named file
# so that group and other are denied write, but have the
# same read and execute permissions as owner.  if the file
# is a directory, recurses.

# change the permissions on all the files in the list
proc dofiles {list} {
  set dirs [collect $list change]
  
  # change file permissions
  foreach p [array names change] {
    set prefix [list exec chmod [format %o $p]]
    eval $prefix $change($p)
  }

  # recurse to subdirectories
  foreach f $dirs {
    dofiles [ldelete */. [ldelete */.. [glob -nocomplain $f/{.*,*}]]]
  }
}


# delete from the list whatever matches pattern
proc ldelete {pattern list} {
  while {[set i [lsearch -glob $list $pattern]] > -1} {
    set list [lreplace $list $i $i]
  }
  return $list
}


# computes new permissions for the listed files
# returns the permissions as indices of the array,
# with the list of files to receive that permission as the value.
# returns a list of the files which are directories.
proc collect {list arrp} {
  upvar 1 $arrp array

  # make an empty array
  catch {unset array}
  set array(x) {}
  unset array(x)

  set dirs {}

  foreach file $list {
    file stat $file stat
    set old $stat(mode)
    set new [expr {($old & ~066) | ((($old & 0500) >> 6) * 011)}]
    if {$old != $new} {
      lappend array($new) $file
    }
    if {![string compare $stat(type) directory]} {
      lappend dirs $file
    }
  }

  return $dirs
}


set myname [file tail $argv0]
if {$argc == 0} {
  puts stderr "Usage: $myname file ...   or   $myname -help"
  exit 1
}
if {$argc==1 && ![string compare -help [lindex $argv 0]]} {
  puts stderr "Usage: $myname file ...   or   $myname -help\n\n\
Changes the permissions on the files so that group and other are denied\n\
write, but have the same read and execute permissions as owner.  If the\n\
file is a directory, recurses."
  exit 1
}

dofiles $argv	
