UPnP

#! /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
fi

## ------------------------ ##
## 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."

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)

    # 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
	}
	uuid:* {
	    set str [string range $spec 5 end]
	    set devtest {[dict get $info uuid] eq $str}
	    set svctest false
	    set devtype uuid
	}
	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"

    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]
    try {
	dom parse [read $fd] doc
    } finally {
	close $fd
    }
    $doc selectNodesNamespaces {ns urn:schemas-upnp-org:device-1-0}
    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 {
	set dir [file normalize $base]
	if {[string equal -length [string length $dir] $dir $file]} {
	    set name [string replace $file 0 [string length $dir]]
	} else {
	    # The main specification is not under the specified base path
	    # Add a special handler to be able to serve this file
	    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]
}