software/tcl/smbnet.tcl

   1 #
   2 # This package provides access for lists of Windows network resources.
   3 # This preliminary version has no error checking and is Windows-only
   4 # Unix version is to be written
   5 #
   6 #
   7 # Toplevel wrapper. Use
   8 #    net domains
   9 #    net computers domain
  10 #    net shares computer ?print?
  11 #    net glob //computer/share/subdir/wildcard
  12 #        note - slashes are _forward_
  13 proc net {args} {
  14     set subcommand [lindex $args 0]
  15     set args [lrange $args 1 end]
  16     if {[lsearch -exact {glob domains computers shares} $subcommand]==-1} {
  17          error  "Usage: net option ?args? where option is one of domains\
  18                 computers shares"
  19      }
  20      uplevel ::smbnet::$subcommand $args
  21 }
  22 namespace eval smbnet {
  23 switch -exact $tcl_platform(platform)  {
  24 "unix" {
  25           #get netbios name of localhost
  26           proc localname {} {
  27             set line [exec nmblookup -A localhost]
  28             if {![regexp "\n\t\(\[^ \]+) +<00>" $line match name]} {
  29                return -code error "Cannot determine local NETBIOS name"
  30             }
  31             return $name
  32           }
  33           variable my_name [localname]
  34           proc domains {} {
  35             # get netbios name of localhost
  36             variable my_name
  37             set line [exec smbclient -N -L  $my_name]
  38             if {![regexp "\n\tWorkgroup +Master\n\t-+ +-+\n(.*)$" \
  39                     $line match line]} {
  40                 return -code error "Cannot get workgroups list"
  41             }
  42             set result {}
  43             foreach elem [split $line \n] {
  44                 if [regexp "^\t(\[^ \]+) " $elem match domain] {
  45                     lappend result $domain
  46                 }
  47
  48             }
  49             return $result
  50          }
  51          proc computers {domain} {
  52             variable my_name
  53             set line [exec smbclient -N -L  $my_name]
  54             if {![regexp "\n\tWorkgroup +Master\n\t-+ +-+\n(.*)$" \
  55                     $line match line]} {
  56                 return -code error "Cannot get workgroups list"
  57             }
  58             foreach elem [split $line \n ] {
  59                 if [regexp "^\t(\[^ \]+) +(\[^ \]+)" $elem match dom master] {
  60                    if {![string compare $dom $domain]} {
  61                        break
  62                    }
  63                    unset master
  64                 }
  65
  66             }
  67             if {![info exists master]} {
  68                 return -code error "Couldn't get master browser for domain $domain"
  69             }
  70             set line [exec smbclient -N -L $master]
  71             if {![regexp "\n\tServer +Comment\n\t-+ +-+\n(.*)\n\n" \
  72                     $line match line]} {
  73                 return -code error "Cannot get server list from $master"
  74             }
  75             set result {}
  76             foreach elem [split $line \n] {
  77                 if {! [string length $elem]} break
  78                 if [regexp "^\t(\[^ \]+) +(\[^ \]+)" $elem match\
  79                         machine comment] {
  80                     lappend result $machine
  81                 }
  82             }
  83             return $result
  84          }
  85          proc shares {computer {sharetype disk}} {
  86             set line [exec smbclient -N -L $computer]
  87             if {![regexp "\n\tSharename +Type +Comment\n\t-+ +-+ +-+\n(.*)\n\n" \
  88                     $line match line]} {
  89                 return -code error "Cannot get shares list from $computer"
  90
  91             }
  92             set result {}
  93             foreach elem [split $line \n] {
  94                 if {![string length $elem]} break
  95                 if {[regexp "^\t(.*) +(Disk|Print|IPC  )" $elem match name type]
  96                         && ![string compare [string trim [string tolower $type]] $sharetype]} {
  97                     lappend result [string trim $name]
  98                 }
  99             }
 100             return $result
 101          }
 102          proc glob {path} {
 103            set list [split $path /]
 104            set share [join [lrange $list 0 3] "\\"]
 105            set realpath [join [lrange $list 4 end] "/"]
 106            set responce [exec smbclient $share << "ls $realpath"]
 107            set result {}
 108            regexp "\nsmb: .>(.*)\n\n" $responce match responce
 109            foreach line [split $responce \n] {
 110               lappend result [string trim [string range $line 0 \
 111                         [expr [string length $line] - 36]]]
 112            }
 113            return $result
 114          }
 115
 116 }
 117 "windows" {
 118     # List SMB domains on current network
 119     proc domains {} {
 120         set domlist [lrange [split [exec net view /domain] "\n"] 4 end]
 121         set final {}
 122         foreach i $domlist {
 123             if {[string match "The command completed*" $i]} break
 124             lappend final [string trim $i]
 125         }
 126         return $final
 127     }
 128     # list computers in the given domain
 129     proc computers domain {
 130         set lines [lrange [split [exec net view /domain:$domain] "\n"] 4 end]
 131         set final {}
 132         foreach i $lines {
 133             if [string match "The command completed*" $i] break
 134             regexp {^\\\\([^ ]+) } $i match name
 135             lappend final $name
 136         }
 137         return $final
 138     }
 139     # list shares of given computer. optionally, sharetype - disk or
 140     # print may be specified
 141     proc shares {computer {sharetype disk}} {
 142         if {$sharetype == "printer"} {
 143             set sharetype print
 144         }
 145         set lines [lrange [split [exec net view "\\\\$computer"] "\n"] 4 end]
 146         foreach l $lines {
 147             if [string match "The command completed*" $l] break
 148             set name ""; set type "";regexp {^(.*) (Print|Disk)} $l\
 149                     match name type
 150             if {[string length $name]&&"$sharetype" == [string tolower $type]} {
 151                 lappend final [string trim $name]
 152             }
 153         }
 154         return $final
 155     }
 156     # list files on the network disk. Note - slashes are forward
 157     proc glob path {
 158         global env
 159         set list [split $path /]
 160         if {[llength $list]>4} {
 161             set globexp [lindex $list end]
 162             if {[regexp {\*\?\[} $globexp]} {
 163                 set list [lreplace $list end end]
 164             } else {
 165                 set globexp *
 166             }
 167         } else {
 168             set globexp *
 169         }
 170         set realpath [join $list "\\"]
 171         set files [split [exec $env(COMSPEC) /c dir /b $realpath] "\n"]
 172         foreach i $files {
 173             if [string match $globexp $i] {
 174                 lappend final $i
 175             }
 176         }
 177         return $final
 178     }
 179
 180 }
 181 default { error "Smbnet is not implemented for $tcl_platform(platform)" }
 182 }
 183 }
 184 package provide Smbnet 0.2