]> wagner.pp.ru Git - sites/home_page.git/blob - software/tcl/smbnet.tcl
grandpa picture
[sites/home_page.git] / 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