File: Multicast.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (282 lines) | stat: -rw-r--r-- 9,182 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
#  Multicast.tcl ---
#      
#  Copyright (c) 1999-2003  Mats Bengtsson
#  
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#  
# $Id: Multicast.tcl,v 1.10 2007-09-14 13:17:09 matben Exp $

package provide Multicast 1.0

namespace eval ::Multicast:: {
    
    variable uid 0
    variable txtvarEntMulticast
    variable selMulticastName
    variable finished
}

# Multicast::OpenMulticast --
#
#       Makes dialog to open streaming audio/video.
#   
# Arguments:
#       wcan        canvas widget
#       
# Results:
#       shows dialog.

proc ::Multicast::OpenMulticast {wcan} {
    global  prefs this wDlgs
    
    variable uid
    variable txtvarEntMulticast
    variable selMulticastName
    variable finished

    set finished -1
    set w $wDlgs(openMulti)[incr uid]
    ::UI::Toplevel $w -macstyle documentProc -usemacmainmenu 1 \
      -macclass {document closeBox}
    # TRANSLATORS: old whiteboard feature
    wm title $w [mc "Open Stream"]

    set shorts [lindex $prefs(shortsMulticastQT) 0]

    # Global frame.
    ttk::frame $w.frall
    pack $w.frall -fill both -expand 1

    set wbox $w.frall.f
    ttk::frame $wbox -padding [option get . dialogPadding {}]
    pack $wbox -fill both -expand 1

    # Labelled frame.
    set frtot $wbox.fr
    ttk::labelframe $frtot -padding [option get . groupSmallPadding {}] \
      -text [mc "Open QuickTime live stream"]
    pack $frtot -side top -fill both
    
    ttk::label $frtot.lbltop -text [mc "Write URL or choose from shortcut"]:
    eval {ttk::optionmenu $frtot.optm  \
      [namespace current]::selMulticastName} $shorts
    ttk::label $frtot.lblhttp -text {http://}
    ttk::entry $frtot.entip -width 40  \
      -textvariable [namespace current]::txtvarEntMulticast
    ttk::label $frtot.msg -style Small.TLabel \
      -wraplength 400 -justify left -text [mc "Open a URL which contains a SDP file with extension .mov for a QuickTime realtime live streaming sending. Can be audio (radio) or video (TV). Alternatively, use your web browser to find the SDP file for a live transmission, download it on disk and open it is an ordinary movie."]

    grid  $frtot.lbltop   -             $frtot.optm  -padx 2 -pady 2 -sticky w
    grid  $frtot.lblhttp  $frtot.entip  -            -padx 2 -pady 2 -sticky e
    grid  $frtot.msg      -             -            -sticky ew
    
    grid  $frtot.optm  $frtot.entip  -sticky ew
    grid columnconfigure $frtot 1 -weight 1
        
    # Button part.
    set frbot $wbox.b
    ttk::frame $frbot -padding [option get . okcancelTopPadding {}]
    ttk::button $frbot.btconn -text [mc "Open"] -default active  \
      -command [list Multicast::OpenMulticastQTStream $wcan $frtot.entip]
    ttk::button $frbot.btcancel -text [mc "Cancel"]  \
      -command [list set [namespace current]::finished 0]
    ttk::button $frbot.btedit -text [mc "Edit"]...   \
      -command [list ::Multicast::DoAddOrEditQTMulticastShort edit $frtot.optm]
    ttk::button $frbot.btadd -text [mc "Add"]...   \
      -command [list ::Multicast::DoAddOrEditQTMulticastShort add $frtot.optm]
    set padx [option get . buttonPadX {}]
    pack  $frbot.btconn  -side right
    pack  $frbot.btcancel  -side right -padx $padx
    pack  $frbot.btedit  -side right
    pack  $frbot.btadd  -side right -padx $padx
    pack  $frbot  -side bottom -fill x
    
    wm resizable $w 0 0
    
    # Grab and focus.
    focus $w
    focus $frtot.entip
    bind $w <Return> "$frbot.btconn invoke"
    trace variable [namespace current]::selMulticastName w  \
      [namespace current]::TraceSelMulticastName
    catch {grab $w}
    tkwait variable [namespace current]::finished
    
    catch {grab release $w}
    destroy $w
    
    return $finished
}

# Multicast::DoAddOrEditQTMulticastShort --
#
#       Process the edit and add buttons. Makes call to 'AddOrEditShortcuts'.
#   
# Arguments:
#       what   "add" or "edit".
#       wOptMenu
#       
# Results:
#       .

proc ::Multicast::DoAddOrEditQTMulticastShort {what wOptMenu} {
    global  prefs
    
    variable selMulticastName
    
    if {[string equal $what "add"]} {
	
	# Use the standard edit shortcuts dialogs. (0: cancel, 1 added)
	set btAns [::EditShortcuts::AddOrEditShortcuts add   \
	  prefs(shortsMulticastQT) -1]
    } elseif {[string equal $what "edit"]} {
	set btAns [::EditShortcuts::EditShortcuts .edtstrm   \
	  prefs(shortsMulticastQT)]
    }
    
    # Update the option menu as a menubutton.
    # Destroying old one and make a new one was the easy way out.
    if {$btAns == 1} {
	set shorts [lindex $prefs(shortsMulticastQT) 0]
	set gridInfo [grid info $wOptMenu]
	destroy $wOptMenu
	set optMenu [eval {tk_optionMenu $wOptMenu   \
	  [namespace current]::selMulticastName} $shorts]
	$wOptMenu configure -highlightthickness 0 -foreground black
	eval {grid $wOptMenu} $gridInfo
    }
}

proc ::Multicast::TraceSelMulticastName {name junk1 junk2} {
    global  prefs
    upvar #0 $name locName
    
    variable txtvarEntMulticast
    
    set ind [lsearch [lindex $prefs(shortsMulticastQT) 0] $locName]
    set txtvarEntMulticast [lindex $prefs(shortsMulticastQT) 1 $ind]
}

# Multicast::OpenMulticastQTStream --
#
#       Initiates a separate download of the tiny SDR file with http.
#   
# Arguments:
#       wcan        canvas widget

proc ::Multicast::OpenMulticastQTStream {wcan wentry} {
    global  this prefs
    variable finished

    # Patterns.
    set proto_ {[^:]+}
    set domain_ {[A-Za-z0-9\-\_\.]+}
    set port_ {[0-9]+}
    set path_ {/.*}
    set url [$wentry get]
    
    # Add leading http:// if not there.
    if {![regexp -nocase "^http://.+" $url]} {
	set url "http://$url"
    }
    
    # Check and parse url.
    unset -nocomplain port
    if {![regexp -nocase "($proto_)://($domain_)(:($port_))?($path_)$"  \
      $url match protocol domain junk port path]} {
	::UI::MessageBox -title [mc "Error"] -message   \
	  "Inconsistent url=$url." -icon error -type ok
	set finished 0
	return
    }
    if {[string length $port] == 0} {
	set port 80
    }
    
    # Somehow we need to pad an extra / here.
    set fileTail [string trim [file tail "junk/[string trim $path /]"] /]
    set fullName [file join $prefs(incomingPath) $fileTail]
    
    if {[string length $fileTail] == 0} {
	tk_dialog .wrfn "No Path" "No file name in path." \
	  error 0 Cancel
	return
    }
    
    # This is opened as an ordinary movie.
    set anchor [::CanvasUtils::NewImportAnchor $wcan]
    ::Import::DoImport $wcan $anchor -url $url
}

proc ::Multicast::CleanupMulticastQTStream {wtop fid fullName token} { 

    upvar #0 $token state    

    set wcan [::WB::GetCanvasFromWtop $wtop]
    set no_ {^2[0-9]+}
    catch {close $fid}
        
    # Access state as a Tcl array.
    # Check errors. 
    if {[info exists state(status)] &&  \
      [string equal $state(status) "timeout"]} {
	::UI::MessageBox -title [mc "Error"] -icon error -type ok \
	  -message "Timout event for url=$state(url)" 
	return
    } elseif {[info exists state(status)] &&  \
      ![string equal $state(status) "ok"]} {
	::UI::MessageBox -title [mc "Error"] -icon error -type ok -message   \
	  "Not ok return code from url=$state(url); status=$state(status)"	  
	return
    }
    
    # The http return status. Must be 2**.
    set httpCode [lindex $state(http) 1]
    if {![regexp "$no_" $httpCode]} {
	::UI::MessageBox -title [mc "Error"] -icon error -type ok \
	  -message "Failed open url=$url. Returned with code: $httpCode."
    }
    
    # Check that type of data is the wanted. Check further.
    if {[info exists state(type)] &&  \
      [string equal $state(type) "video/quicktime"]} {
	::UI::MessageBox -title [mc "Error"] -icon error -type ok -message \
	  "Not correct file type returned from url=$state(url); \
	  filetype=$state(type); expected video/quicktime."
	return
    }
    
    # This is opened as an ordinary movie.
    set anchor [::CanvasUtils::NewImportAnchor $wcan]
    ::Import::DoImport $wcan "$anchor" -file $fullName  \
      -where "local"
    set fileTail [file tail $fullName]
    ::WB::SetStatusMessage $wtop "Opened streaming live multicast: $fileTail."
    update idletasks
}

proc ::Multicast::ProgressMulticastQTStream {wtop fileTail token totalBytes currentBytes} {

    upvar #0 $token state
    
    # Access state as a Tcl array.
    if {$totalBytes != 0} {
	set percentLeft [expr {($totalBytes - $currentBytes)/$totalBytes}]
	set txtLeft ", $percentLeft% left"
    } else {
	set txtLeft ""
    }
    ::WB::SetStatusMessage $wtop "Getting $fileTail$txtLeft"
    update idletasks
}