File: Smbshare.tcl

package info (click to toggle)
tkchooser 2.0652-7
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 432 kB
  • ctags: 272
  • sloc: tcl: 3,344; makefile: 76; sh: 13
file content (460 lines) | stat: -rw-r--r-- 14,204 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
## This is the plugin to handle smb laserwriters under
## tkchooser2. It has no access to global variables, only
## procedures and functions
##
## Ethan Gold <etgold@cs.vassar.edu> 2/24/98
##
## Modified for smbmount 2.0 7/5/99 from user patch

## must provide a name, public name, and icon in addition to
## start and stop procedures

## these don't work as globals, only for
## non-procedural initialization

if {[debug]} { puts "loading smbshare..." }

## register the plugin with the main chooser
register_plugin smb smbshare "Shared Disks"

########## required functions #################

#### required procedures that simply return plugin information
proc smbshare.geticon {} { return "smbshare.pnm" }
proc smbshare.getpubname {} { return "Shared Disks" }
proc smbshare.getprotocol {} { return "smb" }
proc smbshare.afterdelay {} { return "120000" }

if {![info exists smbshare_uselauncher]} {set smbshare_uselauncher 0}

## start function - required
proc smbshare.start {} {
    global smbshare_uselauncher
    if {[debug]} { puts "started Shared Disks Plugin" }

    set entlabel [plug_list_label]
    $entlabel configure -text "File Servers:"
    update
    ## check for "launcher" to see if we can open a directory
    ## automagically after mounting it
    if {[info exists smbshare_uselauncher] \
	    && $smbshare_uselauncher} {
	set_glob smbshare_launcher [check_deps "launcher"]
    }
    smbshare.parseOS
    smbshare.widgets stop
    smbshare.widgets start
    smbshare.refresh
    ## make sure we have smbmount
    if {![llength [check_deps "smbmount"]]} {
	$plugframe.status configure -text "can't find smbmount."
	if {[debug]} {puts "unable to locate smbmount. volume mounting isn't gonna work."}
    }
}

## stop funtion - required
proc smbshare.stop {} {
    if {[debug]} { puts "stopped Shared Disks Plugin" }
    smb.delmachines
    set ID [get_glob afterID]
    if {[string compare $ID ""] != 0 } {
	after cancel $ID
    }
    smbshare.widgets stop
}

## function to call when a listitem is double-clicked
proc smbshare.doubleclick {} {
    if {[debug]} { puts "smbshare: got double-click with [get_curr_item]" }
    set plugframe [plug_frame]
    $plugframe.mount invoke
}

proc smbshare.newzone {} {
    smb.setmachines
    #set plugframe [plug_frame]
    #$plugframe.status configure -text "scanning [smb.getcurrzone]..."
    #update
    #smbshare.clearentities
    #smbshare.showentities [smbshare.getnames]
    #$plugframe.status configure -text "ready."
}

############# End required functions ##################


## procedure to parse the OS name and version
## to detect smbfs support and versions
proc smbshare.parseOS {} {
    global tcl_platform

    ## if we're running under Linux then smbfs is supported
    if {[string compare "$tcl_platform(os)" "Linux"] == 0} {
	set_glob "smbfs" 1
    } else { set_glob "smbfs" 0 }
    
    ## if smbfs is not supported, check for rumba
    ## - not supported yet    
    
}


## entity refresh function
proc smbshare.refresh {} {
    smbshare.newzone
    set_glob afterID [ after [smbshare.afterdelay] {smbshare.refresh}]
}

## pick which procedure based on samba version (this is stupid)
if {[info exists usesamba_205] && $usesamba_205 == 1} {
    puts "using samba-2.0.5 mount syntax"

    ## procedure to actually invoke the mounting commands
    proc smbshare.mountvol {guestflag username password machine filename} {
	global smbshare_uselauncher

	set volume [get_glob volume]
	#set smbmount smbmount
	set filename [tilde $filename]
	set localname [smb.getlocalname]
	
	if {![file readable $filename]} {
	    error "Smbshare" "Mount point $filename unreadable"
	}

	## make sure the needed parameters are set
	if {[string compare $volume ""] == 0} {return}
	if {[string compare $filename ""] == 0} {return}

	if {$guestflag || ![string compare $username ""]} { 
	    set password "-N"
	    set name ""
	} else { 
	    if {[string compare $password ""] == 0} {
		set name "-U $username"
		set password "-N"
	    } else {
		set name "-U $username%$password"
		set password ""
	    }
	}
	
	if {[debug]} {
	    regsub -all {.} $password "\*" fakepass
	    puts "smbshare: mountvol called with $guestflag, \
		    $username, $fakepass, $filename, $volume" 
	}
	
	if {[debug]} {puts "execing: smbmount \"//$machine/$volume\" $filename $fakepass $name"}
	catch {eval exec smbmount \"//$machine/$volume\" $filename $password $name } result

	if {[smb.smbclienterrtest $result]} {return}
	if {[debug]} {puts $result}

	## cute kludge
	if {$smbshare_uselauncher && \
		[string compare [get_glob smbshare_launcher] ""]} {
	    if {[debug]} { puts "smbshare: opening $filename with launcher" }
	    catch {exec [get_glob smbshare_launcher] --nowait $filename &}
	}
    }

} else {

## newer mount-style samba-2.0.6 syntax
    puts "using samba-2.0.6 mount syntax"
    ## procedure to actually invoke the mounting commands
    proc smbshare.mountvol {guestflag username password machine filename} {
	global smbshare_uselauncher smb_currzone

	set volume [get_glob volume]

	set filename [tilde $filename]
	set localname [smb.getlocalname]
	
	if {![file readable $filename]} {
	    error "Smbshare" "Mount point $filename unreadable"
	}

	## make sure the needed parameters are set
	if {[string compare $volume ""] == 0} {return}
	if {[string compare $filename ""] == 0} {return}
	
	lappend options "workgroup=$smb_currzone"
	
	if {$guestflag} {
	    lappend options "guest"
	} else {
	    lappend options "username=$username,password=$password"
	}

	set optstring ""
	foreach option $options {
	    set optstring "$option,$optstring"
	}
	set optstring [string trimright $optstring ","]

	if {[debug]} {
	    regsub -all {.} $password "\*" fakepass
	    puts "smbshare: mountvol called with $guestflag, \
		    $username, $fakepass, $filename, $volume" 
	}
	
	if {[debug]} {puts "execing: smbmount \"//$machine/$volume\" $filename -o $optstring"}
	catch {eval exec smbmount \"//$machine/$volume\" $filename -o $optstring} result

	if {[smb.smbclienterrtest $result]} {return}
	if {[debug]} {puts $result}

	## cute kludge
	if {$smbshare_uselauncher && \
		[string compare [get_glob smbshare_launcher] ""]} {
	    if {[debug]} { puts "smbshare: opening $filename with launcher" }
	    catch {exec [get_glob smbshare_launcher] --nowait $filename &}
	}


    }

## end version test
}

## function to build window to mount volumes
proc smbshare.mountwindow {server} {
    if {[debug]} {puts "smbshare.mountwindow: [get_curr_item]"}
    set username ""
    set password ""
    ## make sure something's selected
    if {[string compare $server ""] == 0} {
	return
    }

    set w ".smbshare_mountwin"
    set smbshareguestflag 0

    ## we are only going to support one mount window
    ## at a time for now. this is easily changed.
    destroy $w
    
    ## build mounting window
    toplevel $w -class Dialog
    set mx [winfo pointerx .]
    set my [winfo pointery .]
    wm geometry $w "+[expr $mx-50]+[expr $my-50]"
    label $w.label -text \
	    " \nConnect to the file server \"$server\" as: \n" \
	    -font [get_propfont]

    checkbutton $w.guest -variable smbshareguestflag \
	    -text "Guest" -font [get_propfont] \
	    -command "toggleentries $w smbshareguestflag"

    label $w.spacelabel1 -text "\n"
    label $w.spacelabel2 -text "\n"
    frame $w.nameframe
    frame $w.passframe
    label $w.nameframe.namelabel -text "Name:     " -font [get_fixedfont]
    label $w.passframe.passlabel -text "Password: " -font [get_fixedfont]
    entry $w.nameframe.name -textvariable username -exportselection 0 \
	    -background white
    entry $w.passframe.pass -textvariable password -exportselection 0 \
	    -show "*" -background white

    pack $w.nameframe.namelabel -side left -anchor n
    pack $w.nameframe.name -side right -anchor n
    pack $w.passframe.passlabel -side left -anchor n
    pack $w.passframe.pass -side right -anchor n
    button $w.cancel -text "Cancel" \
	    -command "destroy $w"
    button $w.ok -text "OK" \
	    -command "destroy $w; smbshare.volwin \"\$smbshareguestflag\" \"\$username\" \"\$password\" \"$server\"" -default active

    pack $w.label -side top -padx 5
    pack $w.guest -side top -anchor w -padx 15
    pack $w.spacelabel1 -side top
    pack $w.nameframe -side top -anchor w  -padx 15
    pack $w.passframe -side top -anchor w  -padx 15
    #pack $w.spacelabel2 -side top
    pack $w.cancel -side left -anchor s -padx 10 -pady 10
    pack $w.ok -side right -anchor s -padx 10 -pady 10
    update
    focus $w.nameframe.name

    bind $w.passframe.pass <Return> "$w.ok invoke"
    bind $w <Control-c> "$w.cancel invoke"
    bind $w.cancel <Return> "$w.cancel invoke"
    bind $w.ok <Return> "$w.ok invoke"
}


## procedure to get a filename, set it globally, and list
## it in the filename widget
proc smbshare.getfilename {filename} {    
    set_glob file "[pwd]/$filename"
    .smbsharewin.fframe.file configure -text [get_glob "file"]
    if {[debug]} { puts "smbshare: file was [get_glob file]" }
}

## procedure to build unmounting window
proc smbshare.unmountwindow {} {
    set_glob volume ""
    set_glob file ""
    set file ""
    set mountpoint ""

    ## build the window
    set w .smbunmountwin
    destroy $w
    toplevel $w -class Dialog
    frame $w.lframe
    label $w.label -text "Mounted smbfs volumes owned by you: " -relief groove
    listbox $w.lframe.volumes -yscrollcommand "$w.lframe.scroll set" \
	    -height 6 -width 40 -exportselection 0 -background white
    scrollbar $w.lframe.scroll -command "$w.lframe.volumes yview" -takefocus 0
    button $w.unmount -text "Unmount" -command \
	    "exec smbumount \[get_glob mountpoint\];\
	    $w.lframe.volumes delete \[$w.lframe.volumes curselection\]"
    button $w.cancel -text "Close" -command "destroy $w"
   
    pack $w.lframe.volumes -side left -fill both -expand 1
    pack $w.lframe.scroll -side right -fill y

    pack $w.label -fill x
    pack $w.lframe -fill both -expand 1
    pack $w.cancel -side left -anchor s -padx 10 -pady 10
    pack $w.unmount -side right -anchor s -padx 10 -pady 10

    bind $w.lframe.volumes <ButtonRelease> \
	    "set_glob mountpoint \[lindex \[$w.lframe.volumes get \[$w.lframe.volumes curselection\]\] 2\]"

    ## fill the mounted volumes listbox
    
    ## open /etc/mtab and get the list of smbfs volumes
    set mtabfd [open /etc/mtab r]
    set mounted(dummy) dum
    unset mounted(dummy)
    while {[gets $mtabfd line] != -1} {
	puts "smbshare: /etc/mtab: $line"
	if {[regexp {.*smbfs.*} $line]} {
	    set entname [lindex $line 0]
	    set mpoint [lindex $line 1]
	    if {[file owned $mpoint]} {
		set mounted($entname) $mpoint
	    }
	}
    }
    
    foreach name [array names mounted] {
	$w.lframe.volumes insert end "$name on $mounted($name)"
    }
    
}

## procedure to call smb mount function
proc smbshare.volwin {guestflag username password machine} {
    if {[debug]} {
	regsub -all {.} $password "\*" fakepass
	puts "smbshare: mountwin called with $guestflag, \
		$username, $fakepass, $machine"
    }

    set_glob volume ""
    set_glob file ""
    set file ""

    ## build the window
    set w .smbsharewin
    destroy $w
    toplevel $w -class Dialog
    frame $w.lframe
    frame $w.fframe
    label $w.label -text "Volumes on $machine: " -relief groove
    listbox $w.lframe.volumes -yscrollcommand "$w.lframe.scroll set" \
	    -height 6 -width 30 -exportselection 0 -background white
    scrollbar $w.lframe.scroll -command "$w.lframe.volumes yview" -takefocus 0
    #message $w.fframe.file -width 200 -relief sunken -text ""
    entry $w.fframe.file -width 20 -relief sunken -textvariable file \
	    -exportselection 0 -background white
    label $w.fframe.label -text "Mount Point: "
    button $w.mount -text "Mount" -command \
	    "smbshare.mountvol $guestflag \"$username\" \"$password\" \"$machine\" \"\$file\""
    button $w.cancel -text "Close" -command "destroy $w"
   
    pack $w.lframe.volumes -side left -expand 1 -fill both
    pack $w.lframe.scroll -side right -fill y
    pack $w.fframe.label -side left
    pack $w.fframe.file -side right

    pack $w.label -fill x
    pack $w.lframe -expand 1 -fill both
    pack $w.fframe
    pack $w.cancel -side left -anchor s -padx 10 -pady 10
    pack $w.mount -side right -anchor s -padx 10 -pady 10

    bind $w.fframe.file <Return> "$w.mount invoke"
    
    bind $w.lframe.volumes <ButtonRelease> \
	    "set_glob volume \[$w.lframe.volumes get \[$w.lframe.volumes curselection\]\]"

    ## fill the listbox with names
    set services [smb.getservices $machine "Disk" $guestflag $username $password]
    foreach name $services {
	$w.lframe.volumes insert end $name
    }
    if {[debug]} {puts "smb: got services: $services"}
}

## procedure to build and destroy smbshare widgets
proc smbshare.widgets {command} {
    set plugframe [plug_frame]
    
    if {[string compare $command "start"] == 0} {
	button $plugframe.mount -text "Mount..." \
		-command {smbshare.mountwindow [get_curr_item]}
	#"smbshare.mountwindow  \"\[get_curr_item\]\""
	button $plugframe.unmount -text "Unmount..." \
		-command "smbshare.unmountwindow"

	## disable the button if smbfs is not available
	if {![get_glob smbfs]} {
	    $plugframe.mount configure -state disabled
	    $plugframe.unmount configure -state disabled
	}

	pack $plugframe.mount
	pack $plugframe.unmount
	$plugframe.status configure -text "ready."
    } else {
	catch {destroy $plugframe.mount}
	catch {destroy $plugframe.unmount}
    }
}

## function to return the machines in the current zone
proc smbshare.getnames {} {
    return [smb.namesfromlkup [smbshare.getentities]]
}

proc smbshare.getentities {} {
    set currzone [smb.getcurrzone]
    set entity ""
    set results [smb.nbplkup $entity]
    set results [smb.namesfromlkup $results]
    return $results
}

## function to display passed in entities in
## the plugin's entity list frame
proc smbshare.showentities {entitylist} {
    set lbox [plug_list]
    foreach entity $entitylist {
	$lbox insert end $entity
    }
}

proc smbshare.clearentities {} {
    set lbox [plug_list]
    $lbox delete 0 end
}

if {[debug]} { puts "finished loading smbshare." }