Check-in [5a240508f4]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:- Update to version 0.2 - Fix some typos - Work with non-hex UUID's - Let the code determine the IP address instead of hardcoding it - Handle failures to get XML files and XML with UTF8 BOM
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1:5a240508f4ffd8ecbb439c3656b71ef9c91ea367
User & Date: schelte 2015-01-10 15:16:09
Context
2015-01-10
15:16
- Update to version 0.2 - Fix some typos - Work with non-hex UUID's - Let the code determine the IP address instead of hardcoding it - Handle failures to get XML files and XML with UTF8 BOM Leaf check-in: 5a240508f4 user: schelte tags: trunk
2014-08-27
15:39
- Specify the correct content type when invoking control commands. check-in: f6f7e5b691 user: schelte tags: trunk
Changes

Changes to configure.

1
2
3
4
5
6
7
8
9
10
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
....
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
....
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
....
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
....
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
....
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
....
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for upnp 0.1.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
................................................................................
subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='upnp'
PACKAGE_TARNAME='upnp'
PACKAGE_VERSION='0.1'
PACKAGE_STRING='upnp 0.1'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

ac_subst_vars='LTLIBOBJS
LIBOBJS
DESTDIR
srcdir
................................................................................
#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures upnp 0.1 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.
................................................................................

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of upnp 0.1:";;
   esac
  cat <<\_ACEOF

Report bugs to the package provider.
_ACEOF
ac_status=$?
fi
................................................................................
    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
upnp configure 0.1
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
................................................................................
## ------------------------ ##
## Autoconf initialization. ##
## ------------------------ ##
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by upnp $as_me 0.1, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{
................................................................................
test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by upnp $as_me 0.1, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@
................................................................................

Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
upnp config.status 0.1
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."



|







 







|
|







 







|







 







|







 







|







 







|







 







|







 







|







1
2
3
4
5
6
7
8
9
10
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
....
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
....
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
....
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
....
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
....
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
....
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for upnp 0.2.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
................................................................................
subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='upnp'
PACKAGE_TARNAME='upnp'
PACKAGE_VERSION='0.2'
PACKAGE_STRING='upnp 0.2'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

ac_subst_vars='LTLIBOBJS
LIBOBJS
DESTDIR
srcdir
................................................................................
#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures upnp 0.2 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.
................................................................................

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of upnp 0.2:";;
   esac
  cat <<\_ACEOF

Report bugs to the package provider.
_ACEOF
ac_status=$?
fi
................................................................................
    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
upnp configure 0.2
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
................................................................................
## ------------------------ ##
## Autoconf initialization. ##
## ------------------------ ##
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by upnp $as_me 0.2, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{
................................................................................
test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by upnp $as_me 0.2, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@
................................................................................

Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
upnp config.status 0.2
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."

Changes to configure.in.

1
2
3
4
5
6
7
8
9
10
11
AC_INIT([upnp], [0.1])

SC_PROG_TCLSH
DESTDIR=`$TCLSH_PROG "${srcdir}/install.tcl" destdir`

AC_SUBST(srcdir)
AC_SUBST(PACKAGE_VERSION)
AC_SUBST(DESTDIR)

AC_CONFIG_FILES([demo], [chmod +x demo])
AC_OUTPUT([Makefile])
|










1
2
3
4
5
6
7
8
9
10
11
AC_INIT([upnp], [0.2])

SC_PROG_TCLSH
DESTDIR=`$TCLSH_PROG "${srcdir}/install.tcl" destdir`

AC_SUBST(srcdir)
AC_SUBST(PACKAGE_VERSION)
AC_SUBST(DESTDIR)

AC_CONFIG_FILES([demo], [chmod +x demo])
AC_OUTPUT([Makefile])

Changes to ssdp.tcl.

101
102
103
104
105
106
107



108
109
110
111
112
113
114
...
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
...
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
...
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382

    # Other messages must have a USN header
    if {![dict exists $hdrs usn]} return

    # Extract the uuid
    if {[scan [dict get $hdrs usn] {uuid:%[0-9a-fA-F-]} uuid] == 1} {
	set uuid [normalize $uuid]



    }

    if {$start eq {NOTIFY * HTTP/1.1}} {
	# Notify message must have a NTS header
	if {![dict exists $hdrs nts]} return
	# Devices going away
	if {[dict get $hdrs nts] eq "ssdp:byebye"} {
................................................................................

proc ssdp::locate {peer spec} {
    variable provider
    # Specification can be all, rootdevices, a uuid, a device, or a service
    switch -glob $spec {
	ssdp:all {
	    set devtest true
	    set svctest {[info exists $info services]}
	    set devtype {root uuid name}
	}
	upnp:rootdevice {
	    set devtest {[dict get $info parent] eq ""}
	    set svctest false
	    set devtype root
	}
................................................................................
	urn:*:device:*:* {
	    set devtest {[satisfies $device $spec]}
	    set svctest false
	    set devtype name
	}
	urn:*:service:*:* {
	    set devtest false
	    set svctest {[info exists $info services]}
	}
    }
    dict for {device info} $provider {
	set uuid [dict get $info uuid]
	if $devtest {
	    set url [dict get $info url]
	    if {"root" in $devtype && [dict get $info parent] eq ""} {
................................................................................
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:device:WANDevice:1
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:service:WANCommonInterfaceConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:device:WANConnectionDevice:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANDSLLinkConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANIPConnection:1

proc ssdp::provide {struct} {
    set myip 192.168.46.3
    set port [dict get $struct port]
    set loc [dict get $struct location]
    set url http://$myip:$port/$loc
    device $url $struct {}

    set cmd [namespace code advertise]
    after cancel $cmd
    # "Devices SHOULD wait a random interval (e.g. between 0 and
    # 100milliseconds) before sending an initial set of advertisements
    # in order to reduce the likelihood of network storms"







>
>
>







 







|







 







|







 







|


|







101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
...
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
...
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385

    # Other messages must have a USN header
    if {![dict exists $hdrs usn]} return

    # Extract the uuid
    if {[scan [dict get $hdrs usn] {uuid:%[0-9a-fA-F-]} uuid] == 1} {
	set uuid [normalize $uuid]
    } elseif {[scan [dict get $hdrs usn] {uuid:%[^:]} uuid] != 1} {
	# Didn't find a uuid
	return
    }

    if {$start eq {NOTIFY * HTTP/1.1}} {
	# Notify message must have a NTS header
	if {![dict exists $hdrs nts]} return
	# Devices going away
	if {[dict get $hdrs nts] eq "ssdp:byebye"} {
................................................................................

proc ssdp::locate {peer spec} {
    variable provider
    # Specification can be all, rootdevices, a uuid, a device, or a service
    switch -glob $spec {
	ssdp:all {
	    set devtest true
	    set svctest {[dict exists $info services]}
	    set devtype {root uuid name}
	}
	upnp:rootdevice {
	    set devtest {[dict get $info parent] eq ""}
	    set svctest false
	    set devtype root
	}
................................................................................
	urn:*:device:*:* {
	    set devtest {[satisfies $device $spec]}
	    set svctest false
	    set devtype name
	}
	urn:*:service:*:* {
	    set devtest false
	    set svctest {[dict exists $info services]}
	}
    }
    dict for {device info} $provider {
	set uuid [dict get $info uuid]
	if $devtest {
	    set url [dict get $info url]
	    if {"root" in $devtype && [dict get $info parent] eq ""} {
................................................................................
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:device:WANDevice:1
# uuid:75802409-bccb-40e7-8e6b-0024FEE6DA60::urn:schemas-upnp-org:service:WANCommonInterfaceConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:device:WANConnectionDevice:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANDSLLinkConfig:1
# uuid:75802409-bccb-40e7-8e6a-0024FEE6DA60::urn:schemas-upnp-org:service:WANIPConnection:1

proc ssdp::provide {struct} {
    set host [dict get $struct host]
    set port [dict get $struct port]
    set loc [dict get $struct location]
    set url http://$host:$port/$loc
    device $url $struct {}

    set cmd [namespace code advertise]
    after cancel $cmd
    # "Devices SHOULD wait a random interval (e.g. between 0 and
    # 100milliseconds) before sending an initial set of advertisements
    # in order to reduce the likelihood of network storms"

Changes to upnp.tcl.

110
111
112
113
114
115
116
117
118






119
120
121
122
123
124
125
...
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
...
179
180
181
182
183
184
185


186
187
188
189
190
191
192



193
194
195
196
197
198
199
...
206
207
208
209
210
211
212

213
214
215
216

217
218
219
220
221
222
223
224
...
231
232
233
234
235
236
237

238
239
240
241
242
243
244
    variable service
    try {
	set ns [dict get $service $uuid tokens $tok]
	namespace eval ::${uuid}::${ns} {}
	dict unset service $uuid tokens $tok

	if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
	    dom parse [http::data $tok] doc
	    http::cleanup $tok






	    $doc documentElement root
	    $doc selectNodesNamespaces [list ns [$root namespaceURI]]
	    foreach act [$root selectNodes //ns:actionList/ns:action] {
		set action [[$act selectNodes ns:name] text]
		set proc ::${uuid}::${ns}::${action}
		set cmd [namespace current]::control
		lappend cmd [dict get $service $uuid $ns service]
................................................................................
	    http::cleanup $tok
	}
	if {[dict size [dict get $service $uuid tokens]] == 0} {
	    dict unset service $uuid tokens
	    set cmdpfx [dict get $service $uuid command]
	    uplevel #0 [linsert $cmdpfx end $uuid]
	}
    } on error err {
	puts $err
    }
}

proc upnp::iconlist {base doc} {
    set rc {}
    foreach node [$doc childNodes] {
	foreach n [$node childNodes] {
................................................................................

proc upnp::control {service url name argnames argvals} {
    set nss http://schemas.xmlsoap.org/soap/envelope/
    set soap [soap $service $name $argnames $argvals]
    lappend hdrs SOAPACTION [format {"%s"} $service#$name]
    http::config -useragent [ssdp agent]
    set tok [geturl $url -type text/xml -headers $hdrs -query $soap]


    dom parse [http::data $tok] doc
    http::cleanup $tok
    $doc selectNodesNamespaces [list s $nss u $service]
    set res [$doc selectNodes /s:Envelope/s:Body/u:${name}Response]
    set rc {}
    foreach n [$res childNodes] {
	dict set rc [$n nodeName] [$n text]



    }
    return $rc
}

proc upnp::advertise {specfile {base ""}} {
    # Parse the specification file, errors should be handled by the caller
    set fd [open $specfile]
................................................................................
    set dict [makedev [$doc selectNodes /ns:root/ns:device]]
	
    # Load wibble, if necessary
    package require wibble
    # Use a different port for each root device to avoid conflicts
    # Pick a port by opening a listening socket. Can't let wibble figure out
    # a port by itself because then it will not be in the state variable

    set fd [socket -server dummy 0]
    set port [lindex [fconfigure $fd -sockname] 2]
    close $fd
    ### Debuging

    set port 49000
    wibble listen $port

    set file [file normalize $specfile]
    set name [file tail $file]
    if {$base eq ""} {
	set dir [file dirname $file]
    } else {
................................................................................
	    wibble handle /$name upnp root $file port $port
	}
    }
    # Handle all (other) urls. It is the callers responsibility to make sure
    # all referenced documents exist under the specified or implied base dir.
    wibble handle / upnp root $dir port $port


    dict set dict port $port
    dict set dict location $name

    ssdp provide $dict
    return [dict get $dict uuid]
}








|

>
>
>
>
>
>







 







|
|







 







>
>
|
|
|
|
<
|
|
>
>
>







 







>
|
|

<
>
|







 







>







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
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
...
216
217
218
219
220
221
222
223
224
225
226

227
228
229
230
231
232
233
234
235
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
    variable service
    try {
	set ns [dict get $service $uuid tokens $tok]
	namespace eval ::${uuid}::${ns} {}
	dict unset service $uuid tokens $tok

	if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
	    set data [http::data $tok]
	    http::cleanup $tok
	    binary scan $data H6 hex
	    if {$hex eq "efbbbf"} {
		# UTF8 BOM found
		set data [encoding convertfrom utf-8 $data]
	    }
	    dom parse $data doc
	    $doc documentElement root
	    $doc selectNodesNamespaces [list ns [$root namespaceURI]]
	    foreach act [$root selectNodes //ns:actionList/ns:action] {
		set action [[$act selectNodes ns:name] text]
		set proc ::${uuid}::${ns}::${action}
		set cmd [namespace current]::control
		lappend cmd [dict get $service $uuid $ns service]
................................................................................
	    http::cleanup $tok
	}
	if {[dict size [dict get $service $uuid tokens]] == 0} {
	    dict unset service $uuid tokens
	    set cmdpfx [dict get $service $uuid command]
	    uplevel #0 [linsert $cmdpfx end $uuid]
	}
    } on error {err info} {
	puts [dict get $info -errorinfo]
    }
}

proc upnp::iconlist {base doc} {
    set rc {}
    foreach node [$doc childNodes] {
	foreach n [$node childNodes] {
................................................................................

proc upnp::control {service url name argnames argvals} {
    set nss http://schemas.xmlsoap.org/soap/envelope/
    set soap [soap $service $name $argnames $argvals]
    lappend hdrs SOAPACTION [format {"%s"} $service#$name]
    http::config -useragent [ssdp agent]
    set tok [geturl $url -type text/xml -headers $hdrs -query $soap]
    set rc {}
    if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {
	dom parse [http::data $tok] doc
	http::cleanup $tok
	$doc selectNodesNamespaces [list s $nss u $service]
	set res [$doc selectNodes /s:Envelope/s:Body/u:${name}Response]

	foreach n [$res childNodes] {
	    dict set rc [$n nodeName] [$n text]
	}
    } else {
	http::cleanup $tok
    }
    return $rc
}

proc upnp::advertise {specfile {base ""}} {
    # Parse the specification file, errors should be handled by the caller
    set fd [open $specfile]
................................................................................
    set dict [makedev [$doc selectNodes /ns:root/ns:device]]
	
    # Load wibble, if necessary
    package require wibble
    # Use a different port for each root device to avoid conflicts
    # Pick a port by opening a listening socket. Can't let wibble figure out
    # a port by itself because then it will not be in the state variable
    # At the same time figure out our local IP address
    set fd [socket -server dummy -myaddr [info hostname] 0]
    lassign [fconfigure $fd -sockname] addr host port
    close $fd

    ### For debugging it may be useful to have a fixed port
    # set port 49000
    wibble listen $port

    set file [file normalize $specfile]
    set name [file tail $file]
    if {$base eq ""} {
	set dir [file dirname $file]
    } else {
................................................................................
	    wibble handle /$name upnp root $file port $port
	}
    }
    # Handle all (other) urls. It is the callers responsibility to make sure
    # all referenced documents exist under the specified or implied base dir.
    wibble handle / upnp root $dir port $port

    dict set dict host $addr
    dict set dict port $port
    dict set dict location $name

    ssdp provide $dict
    return [dict get $dict uuid]
}