Net-UPnP-1.4.3/000755 000765 000024 00000000000 12417652034 013543 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/Build.PL000644 000765 000024 00000000734 12417647446 015056 0ustar00skonnostaff000000 000000 use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Net::UPnP', license => 'bsd', dist_author => 'Satoshi Konno ', dist_version_from => 'lib/Net/UPnP.pm', abstract_from_from => 'lib/Net/UPnP.pm', requires => { 'Test::More' => 0, 'version' => 0, }, add_to_cleanup => [ 'Net-UPnP-*' ], ); $builder->create_build_script(); Net-UPnP-1.4.3/Changes000644 000765 000024 00000007563 12417645621 015055 0ustar00skonnostaff000000 000000 Revision history for Perl extension UPnP. 2014-10-16 Satoshi Konno * v1.4.3 * Added Build.PL for Module::Build. * Updated MANIFEST and Makefile.PL. 2013-12-27 Thomas Liske * Implement handling of chunked "Transfer-Encoding". 2010-08-07 Satoshi Konno * Changed UPnP::AV::MediaServer::getcontentlist() to get contents from non standard UPnP/AV media servers. 2009-07-27 Satoshi Konno * v1.4.2 * Added Net::UPnP::SetDebug(). * Fixed Net:UPnP::ControlPoint::search() not to use uninitialize value on the debug mode. * Added two examples, upnpchk.pl and upnpavchk.pl, to check UPnP and UPnP/AV devices. 2009-06-10 Tim Engler * Fixed Net:UPnP::Device::getdescription() to use a non-greedy match. 2009-02-13 miz * Fixed Net:UPnP::HTTP::post() to convert the line feed to CRLF. 2008-10-15 Satoshi Konno * v1.4.1 * Fixed a documentatin of Net::UPnP::AV::MediaRenderer. 2008-10-13 Satoshi Konno * v1.4 * Added Net::UPnP::AV::MediaRenderer. * Skipped v1.3 because I missed to upload the package. 2008-05-13 Satoshi Konno * v1.2.4 2008-05-07 Christian KrauBe * Added Net::UPnP::GW::gettotalbytessent(). 2008-05-01 Satoshi Konno * Added Net::UPnP::GW::gettotalbytesrecieved(). * Added a sample to use Net::UPnP::GW::gettotalbytesrecieved() into exsample/upnpgwdump.pl. 2006-03-13 Satoshi Konno * v1.2.1 * Added QueryResponse.pm to the package. 2006-03-02 Satoshi Konno * v1.2 * Renamed Net::UPnP::Service::postcontrol() to postaction(). The postcontrol() will be deprecated. * Added Net::UPnP::Service::postquery(). * Added Net::UPnP::GW::Gateway to control IGD, Internet Gateway devices, such as broad band routers. * Added two example, upnpgwdump.pl and upnpgwtool, for Net::UPnP::GW. * Changed upnpavdump.pl to specify the target media server. * Fixed ActionResponse::getargumentlist() to remove extra attributes of the tag name. 2006-01-17 Satoshi Konno * v1.1.3 * Changed postcontrol() in Net::UPnP::Service to create the absolute control url normally using the url base and the relative control url. * Added '--search-title' option to selet the taget contents by the regular expression. 2005-12-20 Satoshi Konno * v1.1.2 * Changed Net::UPnP.pm to get the abstract normally. 2005-12-20 Satoshi Konno * v1.1.1 * Changed Net::UPnP::getdescription() to be able to specify the name. * Added some Net::UPnP::get*() to get the description value of the specified name. * Changed Net::Service::getdevicedescription() to be able to specify the name. * Fixed a test case bug in t/UPnP.t. 2005-12-10 Satoshi Konno * v1.1 * Added 'use warnings' to all packages. * Changed to the package name from UPnP to Net::UPnP * Chanded get*() in Service.pm to return '' instead of undef when the value is not defined. 2005-12-09 Satoshi Konno * v1.0.3 * Changed UPnP::AV::Item, UPnP::Device and Changed UPnP::HTTPResponse to parse the pod correctly. 2005-12-08 Satoshi Konno * v1.0.2 * Changed dms2vodcast.pl to add a option for MPEG4 output format such as 'ipod' and 'psp'. 2005-12-07 Satoshi Konno * v1.0.1 * Changed dms2vodcast.pl upnpavdump.pl to parse all items in the content directory. * Changed upnpavdump.pl to parse all items in the content directory. 2005-12-06 Satoshi Konno * The first release. Net-UPnP-1.4.3/examples/000755 000765 000024 00000000000 12417652034 015361 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/lib/000755 000765 000024 00000000000 12417652034 014311 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/Makefile.PL000644 000765 000024 00000000774 12417650113 015521 0ustar00skonnostaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Net::UPnP', AUTHOR => 'Satoshi Konno ', VERSION_FROM => 'lib/Net/UPnP.pm', ABSTRACT_FROM => 'lib/Net/UPnP.pm', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'version' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Net-UPnP-*' }, ); Net-UPnP-1.4.3/MANIFEST000644 000765 000024 00000001164 12417651201 014671 0ustar00skonnostaff000000 000000 Build.PL Changes examples/upnpdump.pl examples/upnpchk.pl examples/upnpavdump.pl examples/upnpavchk.pl examples/upnpavsimple.pl examples/dms2vodcast.pl examples/upnpgwdump.pl examples/upnpgwtool.pl lib/Net/UPnP.pm lib/Net/UPnP/Device.pm lib/Net/UPnP/Service.pm lib/Net/UPnP/GW/Gateway.pm lib/Net/UPnP/ControlPoint.pm lib/Net/UPnP/AV/MediaServer.pm lib/Net/UPnP/AV/Container.pm lib/Net/UPnP/AV/MediaRenderer.pm lib/Net/UPnP/AV/Item.pm lib/Net/UPnP/AV/Content.pm lib/Net/UPnP/HTTPResponse.pm lib/Net/UPnP/HTTP.pm lib/Net/UPnP/QueryResponse.pm lib/Net/UPnP/ActionResponse.pm Makefile.PL MANIFEST README t/UPnP.t META.yml META.json Net-UPnP-1.4.3/META.json000644 000765 000024 00000001613 12417652034 015165 0ustar00skonnostaff000000 000000 { "abstract" : "Perl extension for UPnP", "author" : [ "Satoshi Konno " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-UPnP", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0", "version" : "0" } } }, "release_status" : "stable", "version" : "v1.4.3" } Net-UPnP-1.4.3/META.yml000644 000765 000024 00000000771 12417652034 015021 0ustar00skonnostaff000000 000000 --- abstract: 'Perl extension for UPnP' author: - 'Satoshi Konno ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-UPnP no_index: directory: - t - inc requires: Test::More: 0 version: 0 version: v1.4.3 Net-UPnP-1.4.3/README000644 000765 000024 00000004223 12353466776 014443 0ustar00skonnostaff000000 000000 Net::UPnP version 1.2.4 =========================== The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it get an idea of the modules uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright (C) 2005-2008 Satoshi Konno All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Net-UPnP-1.4.3/t/000755 000765 000024 00000000000 12417652034 014006 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/t/UPnP.t000644 000765 000024 00000000717 12353466776 015041 0ustar00skonnostaff000000 000000 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl UPnP.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('Net::UPnP') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Net-UPnP-1.4.3/lib/Net/000755 000765 000024 00000000000 12417652034 015037 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/lib/Net/UPnP/000755 000765 000024 00000000000 12417652034 015661 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/lib/Net/UPnP.pm000644 000765 000024 00000005335 12417645677 016244 0ustar00skonnostaff000000 000000 package Net::UPnP; #----------------------------------------------------------------- # UPnP #----------------------------------------------------------------- use version; use strict; use warnings; use vars qw($VERSION $DEBUG $SSDP_ADDR $SSDP_PORT); $VERSION = '1.4.3'; $DEBUG = 0; $SSDP_ADDR = '239.255.255.250'; $SSDP_PORT = 1900; #------------------------------ # id #------------------------------ sub SetDebug() { $DEBUG = $_[0]; } 1; __END__ =head1 NAME Net::UPnP - Perl extension for UPnP =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION This package provides some functions to control UPnP devices. Currently, the package provides only functions for the control point. To control UPnP devices, see L. As a sample of the control point, the package provides L to control the devices such as DLNA media servers. As the example, please dms2vodcast.pl that converts from the MPEG2 movies to the MPEG4 one and outputs the RSS file for Vodcasting. =head1 SEE ALSO L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/ActionResponse.pm000755 000765 000024 00000011027 12353466776 021176 0ustar00skonnostaff000000 000000 package Net::UPnP::ActionResponse; #----------------------------------------------------------------- # Net::UPnP::ActionResponse #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::HTTPResponse; use vars qw($_HTTP_RESPONSE); $_HTTP_RESPONSE = 'httpres'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::ActionResponse::_HTTP_RESPONSE => undef, }; bless $this, $class; } #------------------------------ # header #------------------------------ sub sethttpresponse() { my($this) = shift; $this->{$Net::UPnP::ActionResponse::_HTTP_RESPONSE} = $_[0]; } sub gethttpresponse() { my($this) = shift; $this->{$Net::UPnP::ActionResponse::_HTTP_RESPONSE}; } #------------------------------ # status #------------------------------ sub getstatus() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getstatus(); } sub getstatuscode() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getstatuscode(); } #------------------------------ # header #------------------------------ sub getheader() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getheader(); } #------------------------------ # content #------------------------------ sub getcontent() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getcontent(); } #------------------------------ # content #------------------------------ sub getargumentlist() { my($this) = shift; my( $http_res, %argument_list, $res_statcode, $res_content, $soap_response, $arg_name, $arg_value, @arg_name_token, ); %argument_list = (); $http_res = $this->gethttpresponse(); $res_statcode = $http_res->getstatuscode(); if ($res_statcode != 200) { return \%argument_list; } $res_content = $http_res->getcontent(); if ($res_content =~ m/<.*Response[^>]*>\s*(.*)\s*<\/.*Response>/si) { $soap_response = $1; } while ($soap_response =~ m/<([^>]*)>([^<]*)<\/[^>]*>/sg) { $arg_name = $1; if (0 < index($arg_name, ' ')) { @arg_name_token = split(/ /, $arg_name); if (0 < @arg_name_token) { $arg_name = $arg_name_token[0]; } } $arg_value = $2; $arg_value = Net::UPnP::HTTP::xmldecode($arg_value); $argument_list{$arg_name} = $arg_value; } return \%argument_list; } 1; __END__ =head1 NAME Net::UPnP::ActionResponse - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION The package is used a object of the action response. =head1 METHODS =over 4 =item B - get the status code. $status_code = $actionres->getstatuscode(); Get the status code of the SOAP response. =item B - get the argument list. \%argument_list = $actionres->getargumentlist(); Get the argument list of the SOAP response. =back =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/000755 000765 000024 00000000000 12417652034 016167 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/lib/Net/UPnP/ControlPoint.pm000755 000765 000024 00000011276 12353466776 020702 0ustar00skonnostaff000000 000000 package Net::UPnP::ControlPoint; #----------------------------------------------------------------- # Net::UPnP::ControlPoint #----------------------------------------------------------------- use strict; use warnings; use Socket; use Net::UPnP; use Net::UPnP::HTTP; use Net::UPnP::Device; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = {}; bless $this, $class; } #------------------------------ # search #------------------------------ sub search { my($this) = shift; my %args = ( st => 'upnp:rootdevice', mx => 3, @_, ); my( @dev_list, $ssdp_header, $ssdp_mcast, $rin, $rout, $ssdp_res_msg, $dev_location, $dev_addr, $dev_port, $dev_path, $http_req, $post_res, $post_content, $key, $dev, ); $ssdp_header = <<"SSDP_SEARCH_MSG"; M-SEARCH * HTTP/1.1 Host: $Net::UPnP::SSDP_ADDR:$Net::UPnP::SSDP_PORT Man: "ssdp:discover" ST: $args{st} MX: $args{mx} SSDP_SEARCH_MSG $ssdp_header =~ s/\r//g; $ssdp_header =~ s/\n/\r\n/g; socket(SSDP_SOCK, AF_INET, SOCK_DGRAM, getprotobyname('udp')); $ssdp_mcast = sockaddr_in($Net::UPnP::SSDP_PORT, inet_aton($Net::UPnP::SSDP_ADDR)); send(SSDP_SOCK, $ssdp_header, 0, $ssdp_mcast); if ($Net::UPnP::DEBUG) { print "$ssdp_header\n"; } @dev_list = (); $rin = ''; vec($rin, fileno(SSDP_SOCK), 1) = 1; while( select($rout = $rin, undef, undef, ($args{mx} * 2)) ) { recv(SSDP_SOCK, $ssdp_res_msg, 4096, 0); print "$ssdp_res_msg" if ($Net::UPnP::DEBUG); unless ($ssdp_res_msg =~ m/LOCATION[ :]+(.*)\r/i) { next; } $dev_location = $1; unless ($dev_location =~ m/http:\/\/([0-9a-z.]+)[:]*([0-9]*)\/(.*)/i) { next; } $dev_addr = $1; $dev_port = $2; $dev_path = '/' . $3; $http_req = Net::UPnP::HTTP->new(); $post_res = $http_req->post($dev_addr, $dev_port, "GET", $dev_path, "", ""); if ($Net::UPnP::DEBUG) { print $post_res->getstatus() . "\n"; print $post_res->getheader() . "\n"; print $post_res->getcontent() . "\n"; } $post_content = $post_res->getcontent(); $dev = Net::UPnP::Device->new(); $dev->setssdp($ssdp_res_msg); $dev->setdescription($post_content); if ($Net::UPnP::DEBUG) { print "ssdp = $ssdp_res_msg\n"; print "description = $post_content\n"; } push(@dev_list, $dev); } close(SSDP_SOCK); @dev_list; } 1; __END__ =head1 NAME Net::UPnP::ControlPoint - Perl extension for UPnP control point. =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION The package can search UPnP devices in the local network and get the device list of L. =head1 METHODS =over 4 =item B - create new Net::UPnP::ControlPoint $ctrlPoint = Net::UPnP::ControlPoint(); Creates a new object. Read `perldoc perlboot` if you don't understand that. =item B - search UPnP devices @device_list = $ctrlPoint->search(); @device_list = $ctrlPoint->search( [st => $search_target], # 'upnp:rootdevice' [mx => $maximum_wait] # 3 ); Search UPnP devices and return the device list. Please see L too. =back =head1 SEE ALSO L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/Device.pm000755 000765 000024 00000021515 12353466776 017444 0ustar00skonnostaff000000 000000 package Net::UPnP::Device; #----------------------------------------------------------------- # Net::UPnP::Device #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::Service; use vars qw($_SSDP $_DESCRIPTION $_SERVICELIST); $_SSDP = 'ssdp'; $_DESCRIPTION = 'description'; $_SERVICELIST = 'serviceList'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::Device::_SSDP => '', $Net::UPnP::Device::_DESCRIPTION => '', @Net::UPnP::Device::_SERVICELIST => (), }; bless $this, $class; } #------------------------------ # ssdp #------------------------------ sub setssdp() { my($this) = shift; $this->{$Net::UPnP::Device::_SSDP} = $_[0]; } sub getssdp() { my($this) = shift; $this->{$Net::UPnP::Device::_SSDP}; } #------------------------------ # description #------------------------------ sub setdescription() { my($this) = shift; my($description) = $_[0]; $this->{$Net::UPnP::Device::_DESCRIPTION} = $description; $this->setservicefromdescription($description); } sub getdescription() { my($this) = shift; my %args = ( name => undef, @_, ); if ($args{name}) { # Thanks for Tim Engler (2009/06/10) unless ($this->{$Net::UPnP::Device::_DESCRIPTION} =~ m/<$args{name}>(.*?)<\/$args{name}>/i) { return ''; } return $1; } $this->{$Net::UPnP::Device::_DESCRIPTION}; } #------------------------------ # service #------------------------------ sub setservicefromdescription() { my($this) = shift; my( $description, $servicelist_description, @serviceList, $service, ); $description = $_[0]; unless ($description =~ m/(.*)<\/serviceList>/si) { return; } $servicelist_description = $1; @{$this->{$Net::UPnP::Device::_SERVICELIST}} = (); while ($servicelist_description =~ m/(.*?)<\/service>/sgi) { $service = Net::UPnP::Service->new(); $service->setdevicedescription($1); $service->setdevice($this); push (@{$this->{$Net::UPnP::Device::_SERVICELIST}}, $service); } } #------------------------------ # serviceList #------------------------------ sub getservicelist() { my($this) = shift; @{$this->{$Net::UPnP::Device::_SERVICELIST}}; } #------------------------------ # getservicebyname #------------------------------ sub getservicebyname() { my($this) = shift; my ($service_name) = @_; my ( @serviceList, $service, $service_type, ); @serviceList = $this->getservicelist(); foreach $service (@serviceList) { $service_type = $service->getservicetype(); if ($service_type eq $service_name) { return $service; } } return undef; } #------------------------------ # getlocation #------------------------------ sub getlocation() { my($this) = shift; unless ($this->{$Net::UPnP::Device::_SSDP} =~ m/LOCATION[ :]+(.*)\r/i) { return ''; } return $1; } #------------------------------ # getdevicetype #------------------------------ sub getdevicetype() { my($this) = shift; $this->getdescription(name => 'deviceType'); } #------------------------------ # getfriendlyname #------------------------------ sub getfriendlyname() { my($this) = shift; $this->getdescription(name => 'friendlyName'); } #------------------------------ # getmanufacturer #------------------------------ sub getmanufacturer() { my($this) = shift; $this->getdescription(name => 'manufacturer'); } #------------------------------ # getmanufacturerurl #------------------------------ sub getmanufacturerurl() { my($this) = shift; $this->getdescription(name => 'manufacturerURL'); } #------------------------------ # getmodeldescription #------------------------------ sub getmodeldescription() { my($this) = shift; $this->getdescription(name => 'modelDescription'); } #------------------------------ # getmodelname #------------------------------ sub getmodelname() { my($this) = shift; $this->getdescription(name => 'modelName'); } #------------------------------ # getmodelnumber #------------------------------ sub getmodelnumber() { my($this) = shift; $this->getdescription(name => 'modelNumber'); } #------------------------------ # getmodelurl #------------------------------ sub getmodelurl() { my($this) = shift; $this->getdescription(name => 'modelURL'); } #------------------------------ # getserialnumber #------------------------------ sub getserialnumber() { my($this) = shift; $this->getdescription(name => 'serialNumber'); } #------------------------------ # getudn #------------------------------ sub getudn() { my($this) = shift; $this->getdescription(name => 'UDN'); } #------------------------------ # getupc #------------------------------ sub getupc() { my($this) = shift; $this->getdescription(name => 'UPC'); } #------------------------------ # geturlbase #------------------------------ sub geturlbase() { my($this) = shift; $this->getdescription(name => 'URLBase'); } 1; __END__ =head1 NAME Net::UPnP::Device - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION The package is used a object of UPnP device. =head1 METHODS =over 4 =item B - get the description. $description = $dev->getdescription( name => $name # undef ); Get the device description of the SSDP location header. The function returns the all description when the name parameter is not specified, otherwise return a value the specified name. =item B - get the device type. $description = $dev->getdevicetype(); Get the device type from the device description. =item B - get the device type. $friendlyname = $dev->getfriendlyname(); Get the friendly name from the device description. =item B - get the manufacturer. $manufacturer = $dev->getmanufacturer(); Get the manufacturer name from the device description. =item B - get the manufacturer url. $manufacturer_url = $dev->getmanufacturerrul(); Get the manufacturer url from the device description. =item B - get the model description. $model_description = $dev->getmodeldescription(); Get the model description from the device description. =item B - get the model name. $model_name = $dev->getmodelname(); Get the model name from the device description. =item B - get the model number. $model_number = $dev->getmodelnumber(); Get the model number from the device description. =item B - get the model url. $model_url = $dev->getmodelurl(); Get the model url from the device description. =item B - get the serialnumber. $serialnumber = $dev->getserialnumber(); Get the model description from the device description. =item B - get the device UDN. $udn = $dev->getudn(); Get the UDN from the device description. =item B - get the device UPC. $upc = $dev->getupc(); Get the UPC from the device description. =item B - get the device type. @service_list = $dev->getservicelist(); Get the service list in the device. Please see L too. =back =head1 SEE ALSO L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/GW/000755 000765 000024 00000000000 12417652034 016176 5ustar00skonnostaff000000 000000 Net-UPnP-1.4.3/lib/Net/UPnP/HTTP.pm000755 000765 000024 00000007771 12417645246 017024 0ustar00skonnostaff000000 000000 package Net::UPnP::HTTP; #----------------------------------------------------------------- # Net::UPnP::HTTP #----------------------------------------------------------------- use strict; use warnings; use Socket; use Net::UPnP; use Net::UPnP::HTTPResponse; use vars qw($STATUS_CODE $STATUS $HEADER $CONTENT $POST $GET); $POST = 'POST'; $GET = 'GET'; $STATUS_CODE = 'status_code'; $STATUS = 'status'; $HEADER = 'header'; $CONTENT = 'content'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = {}; bless $this, $class; } #------------------------------ # post #------------------------------ sub post { my($this) = shift; if (@_ < 6) { return ""; } my ($post_addr, $post_port, $method, $path, $add_header, $req_content) = @_; my ( $post_sockaddr, $req_content_len, $add_header_name, $add_header_value, $req_header, $res_status, $res_header_cnt, $res_header, $res_content_len, $res_content, $res, ); # Thanks for miz (2009/02/13) $req_content =~ s/\r//g; $req_content =~ s/\n/\r\n/g; $req_content_len = length($req_content); $req_header = <<"REQUEST_HEADER"; $method $path HTTP/1.0 Host: $post_addr:$post_port Content-Length: $req_content_len REQUEST_HEADER #print "header = " . %{$add_header} . "\n"; #%add_header = %{$add_header_ref}; if (ref $add_header) { while ( ($add_header_name, $add_header_value) = each %{$add_header}) { $req_header .= "$add_header_name: $add_header_value\n"; } } $req_header .= "\n"; $req_header =~ s/\r//g; $req_header =~ s/\n/\r\n/g; $post_sockaddr = sockaddr_in($post_port, inet_aton($post_addr)); socket(HTTP_SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp')); connect(HTTP_SOCK, $post_sockaddr); select(HTTP_SOCK); $|=1; select(STDOUT); if ($Net::UPnP::DEBUG) { print $req_header; print $req_content; } print HTTP_SOCK $req_header; print HTTP_SOCK $req_content; $res_status = ""; $res_header = ""; $res_header_cnt = 0; while() { if (m/^\r\n$/) { last; } $res_header_cnt++; if ($res_header_cnt == 1) { $res_status .= $_; next; } $res_header .= $_; } $res_content_len = 0; if($res_header =~ m/^Content-Length[: ]*(\d+)/i ) { $res_content_len = $1 } my $res_chunked = 0; if($res_header =~ m/^Transfer-Encoding[: ]*chunked/im ) { $res_chunked = 1; } $res_content = ""; if ($res_chunked) { while() { s/[\r\n]//g; my $length = hex($_); my $chunk; read(HTTP_SOCK, $chunk, $length); $res_content .= $chunk; } } elsif ($res_content_len) { read(HTTP_SOCK, $res_content, $res_content_len); } else { while() { $res_content .= $_; } } close(HTTP_SOCK); $res = Net::UPnP::HTTPResponse->new(); $res->setstatus($res_status); $res->setheader($res_header); $res->setcontent($res_content); if ($Net::UPnP::DEBUG) { print $res_status; print $res_header; print $res_content; } return $res; } #------------------------------ # postsoap #------------------------------ sub postsoap { my($this) = shift; my ($post_addr, $post_port, $path, $action_name, $action_content) = @_; my ( %soap_header, $name, $value ); %soap_header = ( 'Content-Type' => "text/xml; charset=\"utf-8\"", 'SOAPACTION' => $action_name, ); $this->post($post_addr, $post_port, $Net::UPnP::HTTP::POST, $path, \%soap_header, $action_content); } #------------------------------ # postsoap #------------------------------ sub xmldecode { my ( $str ); if (ref $_[0]) { $str = $_[1]; } else { $str = $_[0]; } $str =~ s/\>/>/g; $str =~ s/\</ '', $Net::UPnP::HTTPResponse::_HEADER => '', $Net::UPnP::HTTPResponse::_CONTENT => '', }; bless $this, $class; } #------------------------------ # status #------------------------------ sub setstatus() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_STATUS} = $_[0]; } sub getstatus() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_STATUS}; } sub getstatuscode() { my($this) = shift; my($status) = $this->{$Net::UPnP::HTTPResponse::_STATUS}; if (length($status) <= 0) { return 0; } if($status =~ m/^HTTP\/\d.\d\s+(\d+)\s+.*/i ) { return $1; } return 0; } #------------------------------ # header #------------------------------ sub setheader() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_HEADER} = $_[0]; } sub getheader() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_HEADER}; } #------------------------------ # content #------------------------------ sub setcontent() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_CONTENT} = $_[0]; } sub getcontent() { my($this) = shift; $this->{$Net::UPnP::HTTPResponse::_CONTENT}; } 1; __END__ =head1 NAME Net::UPnP::HTTPResponse - Perl extension for UPnP. =head1 DESCRIPTION The package is a inside module. =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/QueryResponse.pm000755 000765 000024 00000010006 12353466776 021062 0ustar00skonnostaff000000 000000 package Net::UPnP::QueryResponse; #----------------------------------------------------------------- # Net::UPnP::QueryResponse #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::HTTPResponse; use vars qw($_HTTP_RESPONSE); $_HTTP_RESPONSE = 'httpres'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::QueryResponse::_HTTP_RESPONSE => undef, }; bless $this, $class; } #------------------------------ # header #------------------------------ sub sethttpresponse() { my($this) = shift; $this->{$Net::UPnP::QueryResponse::_HTTP_RESPONSE} = $_[0]; } sub gethttpresponse() { my($this) = shift; $this->{$Net::UPnP::QueryResponse::_HTTP_RESPONSE}; } #------------------------------ # status #------------------------------ sub getstatus() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getstatus(); } sub getstatuscode() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getstatuscode(); } #------------------------------ # header #------------------------------ sub getheader() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getheader(); } #------------------------------ # content #------------------------------ sub getcontent() { my($this) = shift; my($http_res) = $this->gethttpresponse(); $http_res->getcontent(); } #------------------------------ # content #------------------------------ sub getvalue() { my($this) = shift; my( $http_res, $res_statcode, $res_content, $value, ); $http_res = $this->gethttpresponse(); $res_statcode = $http_res->getstatuscode(); if ($res_statcode != 200) { return ""; } $value = ""; $res_content = $http_res->getcontent(); if ($res_content =~ m/(.*?)<\/return>/si) { $value = $1; } return $value; } 1; __END__ =head1 NAME Net::UPnP::QueryResponse - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION The package is used a object of the action response. =head1 METHODS =over 4 =item B - get the status code. $status_code = $queryres->getstatuscode(); Get the status code of the SOAP response. =item B - get the return value. $value = $queryres->getvalue(); Get the value of the SOAP response. =back =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/Service.pm000755 000765 000024 00000024154 12353466776 017647 0ustar00skonnostaff000000 000000 package Net::UPnP::Service; #----------------------------------------------------------------- # Net::Net::UPnP::Service #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP; use Net::UPnP::ActionResponse; use Net::UPnP::QueryResponse; use vars qw($_DEVICE $_DEVICE_DESCRIPTION $SERVICETYPE $SERVICEID $SCPDURL $CONTROLURL $EVENTSUBURL); $_DEVICE = 'device'; $_DEVICE_DESCRIPTION = 'device_description'; $SERVICETYPE = 'serviceType'; $SERVICEID = 'serviceId'; $SCPDURL = 'SCPDURL'; $CONTROLURL = 'controlURL'; $EVENTSUBURL = 'eventSubURL'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::Service::_DEVICE => undef, $Net::UPnP::Service::_DEVICE_DESCRIPTION => '', }; bless $this, $class; } #------------------------------ # device #------------------------------ sub setdevice() { my($this) = shift; if (@_) { $this->{$Net::UPnP::Service::_DEVICE} = $_[0]; } } sub getdevice() { my($this) = shift; $this->{$Net::UPnP::Service::_DEVICE}; } #------------------------------ # device description #------------------------------ sub setdevicedescription() { my($this) = shift; $this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION} = $_[0]; } sub getdevicedescription() { my($this) = shift; my %args = ( name => undef, @_, ); if ($args{name}) { unless ($this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION} =~ m/<$args{name}>(.*)<\/$args{name}>/i) { return ''; } return $1; } $this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION}; } #------------------------------ # getservicetype #------------------------------ sub getservicetype() { my($this) = shift; $this->getdevicedescription(name => $Net::UPnP::Service::SERVICETYPE); } #------------------------------ # getserviceid #------------------------------ sub getserviceid() { my($this) = shift; $this->getdevicedescription(name => $Net::UPnP::Service::SERVICEID); } #------------------------------ # getscpdurl #------------------------------ sub getscpdurl() { my($this) = shift; $this->getdevicedescription(name => $Net::UPnP::Service::SCPDURL); } #------------------------------ # getcontrolurl #------------------------------ sub getcontrolurl() { my($this) = shift; $this->getdevicedescription(name => $Net::UPnP::Service::CONTROLURL); } #------------------------------ # geteventsuburl #------------------------------ sub geteventsuburl() { my($this) = shift; $this->getdevicedescription(name => $Net::UPnP::Service::EVENTSUBURL); } #------------------------------ # getposturl #------------------------------ sub getposturl() { my($this) = shift; my ($ctrl_url) = @_; my ( $dev, $location_url, $url_base, ); $dev = $this->getdevice(); $location_url = $dev->getlocation(); $url_base = $dev->geturlbase(); $ctrl_url = $this->getcontrolurl(); #print "$location_url\n"; #print "$url_base\n"; #print "$ctrl_url\n"; unless ($ctrl_url =~ m/http:\/\/(.*)/i) { if (0 < length($url_base)) { # Thanks for Thus0 (2005/01/12) if (rindex($url_base, '/') == (length($url_base)-1) && index($ctrl_url, '/') == 0) { $ctrl_url = $url_base . substr($ctrl_url, 1); } else { $ctrl_url = $url_base . $ctrl_url; } } else { if ($location_url =~ m/http:\/\/([0-9a-z.]+)[:]*([0-9]*)\/(.*)/i) { if (defined($3) && 0 < length($3)) { $ctrl_url = "http:\/\/" . $1 . ":" . $2 . $ctrl_url; } else { $ctrl_url = "http:\/\/" . $1 . ":" . $2 . "\/" . $ctrl_url; } } else { $ctrl_url = $location_url . $ctrl_url; } } } return $ctrl_url; } #------------------------------ # postaction #------------------------------ sub postaction() { my($this) = shift; my ($action_name, $action_arg) = @_; my ( $dev, $ctrl_url, $service_type, $soap_action, $soap_content, $arg_name, $arg_value, $post_addr, $post_port, $post_path, $http_req, $post_res, $action_res, $key, ); $action_res = Net::UPnP::ActionResponse->new(); $dev = $this->getdevice(); $ctrl_url = $this->getcontrolurl(); $ctrl_url = $this->getposturl($ctrl_url); unless ($ctrl_url =~ m/http:\/\/([0-9a-z.]+)[:]*([0-9]*)\/(.*)/i) { #print "Invalid URL : $ctrl_url\n"; $post_res = Net::UPnP::HTTPResponse->new(); $action_res->sethttpresponse($post_res); return $action_res; } $post_addr = $1; $post_port = $2; if (index($3, '/') == 0) { $post_path = $3; } else { $post_path = "\/" . $3; } $service_type = $this->getservicetype(); $soap_action = "\"" . $service_type . "#" . $action_name . "\""; $soap_content = <<"SOAP_CONTENT"; \t \t\t SOAP_CONTENT if (ref $action_arg) { while (($arg_name, $arg_value) = each (%{$action_arg} ) ) { if (length($arg_value) <= 0) { $soap_content .= "\t\t\t<$arg_name \/>\n"; next; } $soap_content .= "\t\t\t<$arg_name>$arg_value<\/$arg_name>\n"; } } $soap_content .= <<"SOAP_CONTENT"; \t\t \t SOAP_CONTENT $http_req = Net::UPnP::HTTP->new(); $post_res = $http_req->postsoap($post_addr, $post_port, $post_path, $soap_action, $soap_content); $action_res->sethttpresponse($post_res); return $action_res; } #------------------------------ # postcontrol #------------------------------ sub postcontrol() { my($this) = shift; my ($action_name, $action_arg) = @_; return $this->postaction($action_name, $action_arg); } #------------------------------ # postquery #------------------------------ sub postquery() { my($this) = shift; my ($var_name) = @_; my ( $dev, $ctrl_url, $service_type, $soap_action, $soap_content, $post_addr, $post_port, $post_path, $http_req, $post_res, $query_res, ); $query_res = Net::UPnP::QueryResponse->new(); $dev = $this->getdevice(); $ctrl_url = $this->getcontrolurl(); $ctrl_url = $this->getposturl($ctrl_url); unless ($ctrl_url =~ m/http:\/\/([0-9a-z.]+)[:]*([0-9]*)\/(.*)/i) { #print "Invalid URL : $ctrl_url\n"; $post_res = Net::UPnP::HTTPResponse->new(); $query_res->sethttpresponse($post_res); return $query_res; } $post_addr = $1; $post_port = $2; if (index($3, '/') == 0) { $post_path = $3; } else { $post_path = "\/" . $3; } $service_type = $this->getservicetype(); $soap_action = "\"urn:schemas-upnp-org:control-1-0#QueryStateVariable\""; $soap_content = <<"SOAP_CONTENT"; \t \t\t \t\t\t$var_name \t\t \t SOAP_CONTENT $http_req = Net::UPnP::HTTP->new(); $post_res = $http_req->postsoap($post_addr, $post_port, $post_path, $soap_action, $soap_content); $query_res->sethttpresponse($post_res); return $query_res; } 1; __END__ =head1 NAME Net::UPnP::Service - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } =head1 DESCRIPTION The package is used a object of UPnP service. =head1 METHODS =over 4 =item B - get the device. $description = $service->getdevice(); Get the parent device of the service. =item B - get the service description of the device description. $description = $service->getdevicedescription( name => $name # undef ); Get the service description of the device description. The function returns the all description when the name parameter is not specified, otherwise return a value the specified name. =item B - get the service type. $service_type = $service->getservicetype(); Get the service type. =item B - get the service id. $service_id = $service->getserviceid(); Get the service id. =item B - post a action control. $action_res = $service->postcontrol($action_name, \%action_arg); Post a action control to the device, and return L. The method was renamed from postcontrol(), but the old name is deprecated. =item B - post a query control. $query_res = $service->postcontrol($var_name); Post a query control to the device, and return L. =back =head1 SEE ALSO L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/GW/Gateway.pm000755 000765 000024 00000023755 12353466776 020173 0ustar00skonnostaff000000 000000 package Net::UPnP::GW::Gateway; #----------------------------------------------------------------- # Net::UPnP::GW::Gateway #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::Device; use Net::UPnP::Service; use vars qw($_DEVICE $DEVICE_TYPE $WANIPCONNECTION_SERVICE_TYPE $WANCOMMONINTERFACECONFIG_SERVICE_TYPE); $_DEVICE = 'device'; $DEVICE_TYPE = 'urn:schemas-upnp-org:device:InternetGatewayDevice:1'; $WANIPCONNECTION_SERVICE_TYPE = 'urn:schemas-upnp-org:service:WANIPConnection:1'; $WANCOMMONINTERFACECONFIG_SERVICE_TYPE = 'urn:schemas-upnp-org:service:WANCommonInterfaceConfig:1'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::GW::Gateway::_DEVICE => undef, }; bless $this, $class; } #------------------------------ # device #------------------------------ sub setdevice() { my($this) = shift; if (@_) { $this->{$Net::UPnP::GW::Gateway::_DEVICE} = $_[0]; } } sub getdevice() { my($this) = shift; $this->{$Net::UPnP::GW::Gateway::_DEVICE}; } #------------------------------ # getexternalipaddress #------------------------------ sub getexternalipaddress { my($this) = shift; my ( $dev, $wanipcon_service, $action_res, $arg_list, $ipaddr, ); $dev = $this->getdevice(); $wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE); unless ($wanipcon_service) { return ""; } $action_res = $wanipcon_service->postaction("GetExternalIPAddress"); if ($action_res->getstatuscode() != 200) { return ""; } $arg_list = $action_res->getargumentlist(); $ipaddr = $arg_list->{'NewExternalIPAddress'}; return $ipaddr; } #------------------------------ # getportmappingnumberofentries #------------------------------ sub getportmappingnumberofentries{ my($this) = shift; my ( $dev, $wanipcon_service, $query_res, ); $dev = $this->getdevice(); $wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE); unless ($wanipcon_service) { return 0; } $query_res = $wanipcon_service->postquery("PortMappingNumberOfEntries"); if ($query_res->getstatuscode() != 200) { return 0; } return $query_res->getvalue(); } #------------------------------ # getportmapping #------------------------------ sub getportmappingentry { my($this) = shift; my ( @port_mapping, $dev, $port_mapping_num, $wanipcon_service, $n, %req_arg, $action_res, $arg_list, $ipaddr, ); @port_mapping = (); $port_mapping_num = $this->getportmappingnumberofentries(); if ($port_mapping_num <= 0) { return @port_mapping; } $dev = $this->getdevice(); $wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE); unless ($wanipcon_service) { return @port_mapping ; } for ($n=0; $n<$port_mapping_num; $n++) { #print "[$n]"; %req_arg = ( 'NewPortMappingIndex' => $n, ); $action_res = $wanipcon_service->postaction("GetGenericPortMappingEntry", \%req_arg); #print "[$n]" .$action_res->getstatuscode() . "\n"; #print %req_arg; if ($action_res->getstatuscode() != 200) { push(@port_mapping, undef); next; } $arg_list = $action_res->getargumentlist(); #print $arg_list; push(@port_mapping, $arg_list); } return @port_mapping; } #------------------------------ # addportmapping #------------------------------ sub addportmapping { my($this) = shift; my %args = ( NewRemoteHost => '', NewExternalPort => '', NewProtocol => '', NewInternalPort => '', NewInternalClient => '', NewEnabled => 1, NewPortMappingDescription => '', NewLeaseDuration => 0, @_, ); my ( $dev, $wanipcon_service, $action_res, $arg_list, $ipaddr, %req_arg, ); $dev = $this->getdevice(); $wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE); unless ($wanipcon_service) { return 0; } %req_arg = ( 'NewRemoteHost' => $args{NewRemoteHost}, 'NewExternalPort' => $args{NewExternalPort}, 'NewProtocol' => $args{NewProtocol}, 'NewInternalPort' => $args{NewInternalPort}, 'NewInternalClient' => $args{NewInternalClient}, 'NewEnabled' => $args{NewEnabled}, 'NewPortMappingDescription' => $args{NewPortMappingDescription}, 'NewLeaseDuration' => $args{NewLeaseDuration}, ); $action_res = $wanipcon_service->postaction("AddPortMapping", \%req_arg); if ($action_res->getstatuscode() != 200) { return 0; } return 1; } #------------------------------ # deleteportmapping #------------------------------ sub deleteportmapping { my($this) = shift; my %args = ( NewRemoteHost => '', NewExternalPort => '', NewProtocol => '', @_, ); my ( $dev, $wanipcon_service, $action_res, $arg_list, $ipaddr, %req_arg, ); $dev = $this->getdevice(); $wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE); unless ($wanipcon_service) { return 0; } %req_arg = ( 'NewRemoteHost' => $args{NewRemoteHost}, 'NewExternalPort' => $args{NewExternalPort}, 'NewProtocol' => $args{NewProtocol}, ); $action_res = $wanipcon_service->postaction("DeletePortMapping", \%req_arg); if ($action_res->getstatuscode() != 200) { return 0; } return 1; } #------------------------------ # gettotalbytesrecieved #------------------------------ sub gettotalbytesrecieved { my($this) = shift; my ( $dev, $wanconif_service, $action_res, $arg_list, $totalBytes, ); $dev = $this->getdevice(); $wanconif_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANCOMMONINTERFACECONFIG_SERVICE_TYPE); unless ($wanconif_service) { return ""; } $action_res = $wanconif_service->postaction("GetTotalBytesReceived"); if ($action_res->getstatuscode() != 200) { return ""; } $arg_list = $action_res->getargumentlist(); $totalBytes = $arg_list->{'NewTotalBytesReceived'}; return $totalBytes; } #------------------------------ # gettotalbytessent #------------------------------ sub gettotalbytessent { my($this) = shift; my ( $dev, $wanconif_service, $action_res, $arg_list, $totalBytes, ); $dev = $this->getdevice(); $wanconif_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANCOMMONINTERFACECONFIG_SERVICE_TYPE); unless ($wanconif_service) { return ""; } $action_res = $wanconif_service->postaction("GetTotalBytesSent"); if ($action_res->getstatuscode() != 200) { return ""; } $arg_list = $action_res->getargumentlist(); $totalBytes = $arg_list->{'NewTotalBytesSent'}; return $totalBytes; } 1; __END__ =head1 NAME Net::UPnP::GW::Gateway - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::GW::Gateway; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { # @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:InternetGatewayDevice:1', mx => 10); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { my $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) { next; } my $gwdev = Net::UPnP::GW::Gateway->new(); $gwdev->setdevice($dev); print "\tExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n"; print "\tPortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n"; @port_mapping = $gwdev->getportmappingentry(); $port_num = 0; foreach $port_entry (@port_mapping) { if ($port_entry) { $port_map_name = $port_entry->{'NewPortMappingDescription'}; if (length($port_map_name) <= 0) { $port_map_name = "(No name)"; } print " [$port_num] : $port_map_name\n"; foreach $name ( keys %{$port_entry} ) { print " $name = $port_entry->{$name}\n"; } } else { print " [$port_num] : Unknown\n"; } $port_num++; } } =head1 DESCRIPTION The package is a extention UPnP/GW. =head1 METHODS =over 4 =item B - create new Net::UPnP::GW::Gateway. $mservier = Net::UPnP::GW::Gateway(); Creates a new object. Read `perldoc perlboot` if you don't understand that. The new object is not associated with any UPnP devices. Please use setdevice() to set the device. =item B - set a UPnP devices $gw->setdevice($dev); Set a device to the object. =item B - External IP address $gw->getexternalipaddress(); Get the external IP address. =item B - PortMappingNumberOfEntries $gw->getexternalipaddress(); Get the number of the port mapping entries. =item B - PortMappingEntry $gw->getexternalipaddress(); Get the port mapping entries. =item B - add new port mapping. $result = gw->addportmapping( NewRemoteHost # '', NewExternalPort # '', NewProtocol # '', NewInternalPort # '', NewInternalClient # '', NewEnabled #1, NewPortMappingDescription # '', NewLeaseDuration # 0); Add a new specified port mapping. =item B - delete a port mapping. $result = gw->deleteportmapping( NewRemoteHost # '', NewExternalPort # '', NewProtocol # ''); Delete the specified port mapping. =item B - Total recieved bytes. $gw->gettotalbytesrecieved(); Get the total recieved bytes. =back =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/Container.pm000755 000765 000024 00000006375 12353466776 020504 0ustar00skonnostaff000000 000000 package Net::UPnP::AV::Container; #----------------------------------------------------------------- # Net::UPnP::AV::Container #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::AV::Content; use vars qw(@ISA); @ISA = qw(Net::UPnP::AV::Content); #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = $class->SUPER::new(); bless $this, $class; } #------------------------------ # is* #------------------------------ sub iscontainer() { 1; } 1; =head1 NAME Net::UPnP::AV::Container - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach $content (@content_list) { print_content($mediaServer, $content, 1); } $devNum++; } sub print_content { my ($mediaServer, $content, $indent) = @_; my $id = $content->getid(); my $title = $content->gettitle(); for ($n=0; $n<$indent; $n++) { print "\t"; } print "$id = $title"; if ($content->isitem()) { print " (" . $content->geturl(); if (length($content->getdate())) { print " - " . $content->getdate(); } print " - " . $content->getcontenttype() . ")"; } print "\n"; unless ($content->iscontainer()) { return; } @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } $indent++; foreach my $child_content (@child_content_list) { print_content($mediaServer, $child_content, $indent); } } =head1 DESCRIPTION The package is a extention UPnP/AV media server, and a sub class of L. =head1 METHODS =over 4 =item B - Check if the content is a container. $isContainer = $container->iscontainer(); Check if the content is a container. =item B - Get the content ID. $id = $item->getid(); Get the content ID. =item B - Get the content title. $title = $item->gettitle(); Get the content title. =item B - Get the content date. $date = $item->getdate(); Get the content date. =back =head1 SEE ALSO L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/Content.pm000755 000765 000024 00000010015 12353466776 020156 0ustar00skonnostaff000000 000000 package Net::UPnP::AV::Content; #----------------------------------------------------------------- # Net::UPnP::AV::Content #----------------------------------------------------------------- use strict; use warnings; use vars qw($_ID $_TITLE $_DATE); $_ID = '_id'; $_TITLE = '_title'; $_DATE = '_date'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::AV::Content::_ID => '', $Net::UPnP::AV::Content::_TITLE => '', $Net::UPnP::AV::Content::_DATE => '', }; bless $this, $class; } #------------------------------ # id #------------------------------ sub setid() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::Content::_ID} = $_[0]; } } sub getid() { my($this) = shift; $this->{$Net::UPnP::AV::Content::_ID}; } #------------------------------ # title #------------------------------ sub settitle() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::Content::_TITLE} = $_[0]; } } sub gettitle() { my($this) = shift; $this->{$Net::UPnP::AV::Content::_TITLE}; } #------------------------------ # date #------------------------------ sub setdate() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::Content::_DATE} = $_[0]; } } sub getdate() { my($this) = shift; $this->{$Net::UPnP::AV::Content::_DATE}; } #------------------------------ # is* #------------------------------ sub iscontainer() { 0; } sub isitem() { 0; } 1; __END__ =head1 NAME Net::UPnP::AV::Content - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach $content (@content_list) { print_content($mediaServer, $content, 1); } $devNum++; } sub print_content { my ($mediaServer, $content, $indent) = @_; my $id = $content->getid(); my $title = $content->gettitle(); for ($n=0; $n<$indent; $n++) { print "\t"; } print "$id = $title"; if ($content->isitem()) { print " (" . $content->geturl(); if (length($content->getdate())) { print " - " . $content->getdate(); } print " - " . $content->getcontenttype() . ")"; } print "\n"; unless ($content->iscontainer()) { return; } @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } $indent++; foreach my $child_content (@child_content_list) { print_content($mediaServer, $child_content, $indent); } } =head1 DESCRIPTION The package is a extention UPnP/AV media server, and a super class of L and L. =head1 METHODS =over 4 =item B - Get the content ID. $id = $item->getid(); Get the content ID. =item B - Get the content title. $title = $item->gettitle(); Get the content title. =item B - Get the content date. $date = $item->getdate(); Get the content date. =back =head1 SEE ALSO L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/Item.pm000755 000765 000024 00000010151 12353466776 017443 0ustar00skonnostaff000000 000000 package Net::UPnP::AV::Item; #----------------------------------------------------------------- # Net::UPnP::AV::Item #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::AV::Content; use vars qw(@ISA $_URL $_CONTENTTYPE); @ISA = qw(Net::UPnP::AV::Content); $_URL = '_url'; $_CONTENTTYPE = '_contenttype'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = $class->SUPER::new(); $this->{$Net::UPnP::AV::Item::_URL} = ''; $this->{$Net::UPnP::AV::Item::_CONTENTTYPE} = ''; bless $this, $class; } #------------------------------ # url #------------------------------ sub seturl() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::Item::_URL} = $_[0]; } } sub geturl() { my($this) = shift; $this->{$Net::UPnP::AV::Item::_URL}; } #------------------------------ # contenttype #------------------------------ sub setcontenttype() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::Item::_CONTENTTYPE} = $_[0]; } } sub getcontenttype() { my($this) = shift; $this->{$Net::UPnP::AV::Item::_CONTENTTYPE}; } #------------------------------ # is* #------------------------------ sub isitem() { 1; } 1; __END__ =head1 NAME Net::UPnP::AV::Item - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach $content (@content_list) { print_content($mediaServer, $content, 1); } $devNum++; } sub print_content { my ($mediaServer, $content, $indent) = @_; my $id = $content->getid(); my $title = $content->gettitle(); for ($n=0; $n<$indent; $n++) { print "\t"; } print "$id = $title"; if ($content->isitem()) { print " (" . $content->geturl(); if (length($content->getdate())) { print " - " . $content->getdate(); } print " - " . $content->getcontenttype() . ")"; } print "\n"; unless ($content->iscontainer()) { return; } @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } $indent++; foreach my $child_content (@child_content_list) { print_content($mediaServer, $child_content, $indent); } } =head1 DESCRIPTION The package is a extention UPnP/AV media server, and a sub class of L. =head1 METHODS =over 4 =item B - Check if the content is a item. $isItem = $item->isisitem(); Check if the content is a item. =item B - Get the content ID. $id = $item->getid(); Get the content ID. =item B - Get the content title. $title = $item->gettitle(); Get the content title. =item B - Get the content date. $date = $item->getdate(); Get the content date. =item B - get the content URL $url = $item->getcontenttype(); Get the content URL. =item B - get the content type $content_type = $item->getcontenttype(); Get the content type. =back =head1 SEE ALSO L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/MediaRenderer.pm000755 000765 000024 00000013740 12353466776 021262 0ustar00skonnostaff000000 000000 package Net::UPnP::AV::MediaRenderer; #----------------------------------------------------------------- # Net::UPnP::AV::Renderer #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::Device; use Net::UPnP::Service; use Net::UPnP::AV::Container; use Net::UPnP::AV::Item; use vars qw($_DEVICE $DEVICE_TYPE $AVTRNSPORT_SERVICE_TYPE); $_DEVICE = 'device'; $DEVICE_TYPE = 'urn:schemas-upnp-org:device:MediaRenderer:1'; $AVTRNSPORT_SERVICE_TYPE = 'urn:schemas-upnp-org:service:AVTransport:1'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::AV::MediaRenderer::_DEVICE => undef, }; bless $this, $class; } #------------------------------ # device #------------------------------ sub setdevice() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::MediaRenderer::_DEVICE} = $_[0]; } } sub getdevice() { my($this) = shift; $this->{$Net::UPnP::AV::MediaRenderer::_DEVICE}; } #------------------------------ # setAVTransportURI #------------------------------ sub setAVTransportURI { my($this) = shift; my %args = ( InstanceID => 0, CurrentURI => '', CurrentURIMetaData => '', @_, ); my ( $dev, $avtrans_service, %req_arg, ); $dev = $this->getdevice(); $avtrans_service = $dev->getservicebyname($Net::UPnP::AV::MediaRenderer::AVTRNSPORT_SERVICE_TYPE); %req_arg = ( 'InstanceID' => $args{InstanceID}, 'CurrentURI' => $args{CurrentURI}, 'CurrentURIMetaData' => $args{CurrentURIMetaData}, ); $avtrans_service->postaction("SetAVTransportURI", \%req_arg); } #------------------------------ # setNextAVTransportURI #------------------------------ sub setNextAVTransportURI { my($this) = shift; my %args = ( InstanceID => 0, NextURI => '', NextURIMetaData => '', @_, ); my ( $dev, $avtrans_service, %req_arg, ); $dev = $this->getdevice(); $avtrans_service = $dev->getservicebyname($Net::UPnP::AV::MediaRenderer::AVTRNSPORT_SERVICE_TYPE); %req_arg = ( 'InstanceID' => $args{InstanceID}, 'NextURI' => $args{NextURI}, 'NextURIMetaData' => $args{NextURIMetaData}, ); $avtrans_service->postaction("SetNextAVTransportURI", \%req_arg); } #------------------------------ # Play #------------------------------ sub play { my($this) = shift; my %args = ( InstanceID => 0, Speed => 1, @_, ); my ( $dev, $avtrans_service, %req_arg, ); $dev = $this->getdevice(); $avtrans_service = $dev->getservicebyname($Net::UPnP::AV::MediaRenderer::AVTRNSPORT_SERVICE_TYPE); %req_arg = ( 'InstanceID' => $args{InstanceID}, 'Speed' => $args{Speed}, ); $avtrans_service->postaction("Play", \%req_arg); } #------------------------------ # Stop #------------------------------ sub stop { my($this) = shift; my %args = ( InstanceID => 0, @_, ); my ( $dev, $avtrans_service, %req_arg, ); $dev = $this->getdevice(); $avtrans_service = $dev->getservicebyname($Net::UPnP::AV::MediaRenderer::AVTRNSPORT_SERVICE_TYPE); %req_arg = ( 'InstanceID' => $args{InstanceID}, ); $avtrans_service->postaction("Stop", \%req_arg); } 1; __END__ =head1 NAME Net::UPnP::AV::MediaRenderer - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaRenderer; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { my $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaRenderer:1') { next; } my $friendlyname = $dev->getfriendlyname(); print "[$devNum] : " . $friendlyname . "\n"; my $renderer = Net::UPnP::AV::MediaRenderer->new(); $renderer->setdevice($dev); $renderer->stop(); $renderer->setAVTransportURI(CurrentURI => 'http://xxx.xxx.xxx.xxx/xxxx.mpg'); $renderer->play(); $devNum++; } =head1 DESCRIPTION The package is a extention UPnP/AV media server. =head1 METHODS =over 4 =item B - create new Net::UPnP::AV::MediaRenderer. $renderer = Net::UPnP::AV::MediaRenderer(); Creates a new object. Read `perldoc perlboot` if you don't understand that. The new object is not associated with any UPnP devices. Please use setdevice() to set the device. =item B - set a UPnP devices $renderer->setdevice($dev); Set a device to the object. =item B - set a current content. @action_response = $renderer->setAVTransportURI( InstanceID => $instanceID, # 0 CurrentURI => $url, # '' CurrentURIMetaData => $metaData, # "' ); Set a current content to play, L. =item B - set a next content. @action_response = $renderer->setNextAVTransportURI( InstanceID => $instanceID, # 0 NextURI => $url, # '' NextURIMetaData => $metaData, # "' ); Set a next content to play, L. =item B - play. @action_response = $renderer->play( InstanceID => $instanceID, # 0 Speed => $url, # 1 ); Play the specified content. =item B - stop. @action_response = $renderer->stop( InstanceID => $instanceID, # 0 ); Stop the playing content. =back =head1 SEE ALSO L L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/lib/Net/UPnP/AV/MediaServer.pm000755 000765 000024 00000023760 12353466776 020765 0ustar00skonnostaff000000 000000 package Net::UPnP::AV::MediaServer; #----------------------------------------------------------------- # Net::UPnP::AV::MediaServer #----------------------------------------------------------------- use strict; use warnings; use Net::UPnP::HTTP; use Net::UPnP::Device; use Net::UPnP::Service; use Net::UPnP::AV::Container; use Net::UPnP::AV::Item; use vars qw($_DEVICE $DEVICE_TYPE $CONTENTDIRECTORY_SERVICE_TYPE); $_DEVICE = 'device'; $DEVICE_TYPE = 'urn:schemas-upnp-org:device:MediaServer:1'; $CONTENTDIRECTORY_SERVICE_TYPE = 'urn:schemas-upnp-org:service:ContentDirectory:1'; #------------------------------ # new #------------------------------ sub new { my($class) = shift; my($this) = { $Net::UPnP::AV::MediaServer::_DEVICE => undef, }; bless $this, $class; } #------------------------------ # device #------------------------------ sub setdevice() { my($this) = shift; if (@_) { $this->{$Net::UPnP::AV::MediaServer::_DEVICE} = $_[0]; } } sub getdevice() { my($this) = shift; $this->{$Net::UPnP::AV::MediaServer::_DEVICE}; } #------------------------------ # browse #------------------------------ sub browse { my($this) = shift; my %args = ( ObjectID => 0, BrowseFlag => 'BrowseDirectChildren', Filter => '*', StartingIndex => 0, RequestedCount => 0, SortCriteria => '', @_, ); my ($objid, $browseFlag, $filter, $startIdx, $reqCount, $sortCriteria) = @_; my ( $dev, $condir_service, %req_arg, $action_res, ); $dev = $this->getdevice(); $condir_service = $dev->getservicebyname($Net::UPnP::AV::MediaServer::CONTENTDIRECTORY_SERVICE_TYPE); %req_arg = ( 'ObjectID' => $args{ObjectID}, 'BrowseFlag' => $args{BrowseFlag}, 'Filter' => $args{Filter}, 'StartingIndex' => $args{StartingIndex}, 'RequestedCount' => $args{RequestedCount}, 'SortCriteria' => $args{SortCriteria}, ); $condir_service->postaction("Browse", \%req_arg); } sub browsedirectchildren { my($this) = shift; my %args = ( ObjectID => 0, Filter => '*', StartingIndex => 0, RequestedCount => 0, SortCriteria => '', @_, ); $this->browse ( ObjectID => $args{ObjectID}, BrowseFlag => 'BrowseDirectChildren', Filter => $args{Filter}, StartingIndex => $args{StartingIndex}, RequestedCount => $args{RequestedCount}, SortCriteria => $args{SortCriteria} ); } sub browsemetadata { my($this) = shift; my %args = ( ObjectID => 0, Filter => '*', StartingIndex => 0, RequestedCount => 0, SortCriteria => '', @_, ); $this->browse ( ObjectID => $args{ObjectID}, BrowseFlag => 'BrowseMetadata', Filter => $args{Filter}, StartingIndex => $args{StartingIndex}, RequestedCount => $args{RequestedCount}, SortCriteria => $args{SortCriteria} ); } #------------------------------ # getdirectchildren #------------------------------ sub getcontentlist { my($this) = shift; my %args = ( ObjectID => 0, Filter => '*', StartingIndex => 0, RequestedCount => 0, SortCriteria => '', @_, ); my ( @content_list, $action_res, $arg_list, $result, $content, $container, $item, $numberReturned, $requestedCount, $totalMatches ); @content_list = (); $action_res = $this->browsedirectchildren( ObjectID => $args{ObjectID}, Filter => $args{Filter}, StartingIndex => $args{StartingIndex}, RequestedCount => $args{RequestedCount}, SortCriteria => $args{SortCriteria} ); $numberReturned = 0; if ($action_res->getstatuscode() == 200) { $arg_list = $action_res->getargumentlist(); $numberReturned = int($arg_list->{'NumberReturned'}); } if ($numberReturned <= 0) { $action_res = $this-> browsemetadata( ObjectID => $args{ObjectID}, Filter => $args{Filter}, StartingIndex => $args{StartingIndex}, RequestedCount => $args{RequestedCount}, SortCriteria => $args{SortCriteria} ); $requestedCount = 999; if ($action_res->getstatuscode() == 200) { $arg_list = $action_res->getargumentlist(); $totalMatches = int($arg_list->{'TotalMatches'}); if (1 < $totalMatches) { $requestedCount = $totalMatches; } } $action_res = $this->browsedirectchildren( ObjectID => $args{ObjectID}, Filter => $args{Filter}, StartingIndex => $args{StartingIndex}, RequestedCount => $requestedCount, SortCriteria => $args{SortCriteria} ); if ($action_res->getstatuscode() != 200) { return @content_list; } } $arg_list = $action_res->getargumentlist(); unless ($arg_list->{'Result'}) { return @content_list; } $result = $arg_list->{'Result'}; while ($result =~ m//sgi) { $content = $1; $container = Net::UPnP::AV::Container->new(); if ($content =~ m/id=\"(.*?)\"/si) { $container->setid($1); } if ($content =~ m/(.*)<\/dc:title>/si) { $container->settitle($1); } if ($content =~ m/(.*)<\/dc:date>/si) { $container->setdate($1); } push (@content_list, $container); #print "container(" . $container->getid() . ") = " . $container->gettitle() . "\n"; #print $1; } while ($result =~ m//sgi) { $content = $1; $item= Net::UPnP::AV::Item->new(); if ($content =~ m/id=\"(.*?)\"/si) { $item->setid($1); } if ($content =~ m/(.*)<\/dc:title>/si) { $item->settitle($1); } if ($content =~ m/(.*)<\/dc:date>/si) { $item->setdate($1); } if ($content =~ m/]*>(.*?)<\/res>/si) { $item->seturl(Net::UPnP::HTTP::xmldecode($1)); } if ($content =~ m/protocolInfo=\"http-get:[^:]*:([^:]*):.*\"/si) { $item->setcontenttype($1); } elsif ($content =~ m/protocolInfo=\"[^:]*:[^:]:([^:]*):.*\"/si) { $item->setcontenttype($1); } push (@content_list, $item); } @content_list; } #------------------------------ # getsystemupdateid #------------------------------ sub getsystemupdateid { my($this) = shift; my ( $dev, $condir_service, $query_res, ); $dev = $this->getdevice(); $condir_service = $dev->getservicebyname($Net::UPnP::AV::MediaServer::CONTENTDIRECTORY_SERVICE_TYPE); $query_res = $condir_service->postquery("SystemUpdateID"); if ($query_res->getstatuscode() != 200) { return ""; } return $query_res->getvalue(); } 1; __END__ =head1 NAME Net::UPnP::AV::MediaServer - Perl extension for UPnP. =head1 SYNOPSIS use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach $content (@content_list) { print_content($mediaServer, $content, 1); } $devNum++; } sub print_content { my ($mediaServer, $content, $indent) = @_; my $id = $content->getid(); my $title = $content->gettitle(); for ($n=0; $n<$indent; $n++) { print "\t"; } print "$id = $title"; if ($content->isitem()) { print " (" . $content->geturl(); if (length($content->getdate())) { print " - " . $content->getdate(); } print " - " . $content->getcontenttype() . ")"; } print "\n"; unless ($content->iscontainer()) { return; } @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } $indent++; foreach my $child_content (@child_content_list) { print_content($mediaServer, $child_content, $indent); } } =head1 DESCRIPTION The package is a extention UPnP/AV media server. =head1 METHODS =over 4 =item B - create new Net::UPnP::AV::MediaServer. $mservier = Net::UPnP::AV::MediaServer(); Creates a new object. Read `perldoc perlboot` if you don't understand that. The new object is not associated with any UPnP devices. Please use setdevice() to set the device. =item B - set a UPnP devices $mservier->setdevice($dev); Set a device to the object. =item B - browse the content directory. @action_response = $mservier->browse( ObjectID => $objid, # 0 BrowseFlag => $browseFlag, # 'BrowseDirectChildren' Filter => $filter, # "*' StartingIndex => $startIndex, # 0 RequestedCount => $reqCount, # 0 SortCriteria => $sortCrit # '' ); Browse the content directory and return the action response, L. =item B - get the content list. @content_list = $mservier->getcontentlist( ObjectID => $objid, # 0 Filter => $filter, # "*' StartingIndex => $startIndex, # 0 RequestedCount => $reqCount, # 0 SortCriteria => $sortCrit # '' ); Browse the content directory and return the content list. Please see L, L and L. =back =head1 SEE ALSO L L L =head1 AUTHOR Satoshi Konno skonno@cybergarage.org CyberGarage http://www.cybergarage.org =head1 COPYRIGHT AND LICENSE Copyright (C) 2005 by Satoshi Konno It may be used, redistributed, and/or modified under the terms of BSD License. =cut Net-UPnP-1.4.3/examples/dms2vodcast.pl000755 000765 000024 00000022207 12353466776 020174 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; use Shell qw(curl ffmpeg); #curl('--version'); #ffmpeg('-version'); #------------------------------ # program info #------------------------------ $program_name = 'DLNA Media Sever 2 Vodcast'; $copy_right = 'Copyright (c) 2005 Satoshi Konno'; $script_name = 'dms2vodcast.pl'; $script_version = '1.0.3'; #------------------------------ # global variables #------------------------------ @dms_content_list = (); #------------------------------ # command option #------------------------------ $rss_file_name = ""; $base_directory = "./"; $rss_base_url= "http://localhost"; $rss_description = "CyberGarage Vodcast"; $rss_language = ""; $rss_link= ""; $rss_title = "CyberGarage"; $requested_count = 0; $mp4_format = 'ipod'; $title_regexp = ""; @command_opt = ( ['-b', '--base-url', '', 'Set the base url in the item link property of the output RSS file'], ['-B', '--base-directory', '', 'Set the base directory to output the RSS file and the MPEG4 files'], ['-d', '--rss-description', '', 'Set the description tag in the output RSS file'], ['-g', '--rss-language', '', 'Set the language tag in the output RSS file'], ['-h', '--help', '', 'This is help text.'], ['-l', '--rss-link', '', 'Set the link tag in the output RSS file'], ['-r', '--requested-count', '', 'Set the max request count to the media server contents'], ['-t', '--rss-title', '', 'Set the title tag in the output RSS file'], ['-f', '--mp4-format', '', 'Set the MPEG4 format'], ['-s', '--search-title', '', 'Set the regular expression of the content titles by UTF-8'], ); sub is_command_option { ($opt) = @_; for ($n=0; $n<@command_opt; $n++) { if ($opt eq $command_opt[$n][0] || $opt eq $command_opt[$n][1]) { return $n; } } return -1; } #------------------------------ # main (pase command line) #------------------------------ for ($i=0; $i<(@ARGV); $i++) { $opt = $ARGV[$i]; $opt_num = is_command_option($opt); $opt_short_name = ''; if ($opt_num < 0) { if ($opt =~ m/^-/) { print "$script_name : option $opt is unknown\n"; print "$script_name : try \'$script_name --help\' for more information \n"; exit 1; } } else { $opt_short_name = $command_opt[$opt_num][0]; } if ($opt_short_name eq '-h') { print "Usage : $script_name [options...] \n"; print "Options : \n"; $max_opt_output_len = 0; for ($n=0; $n<@command_opt; $n++) { $opt_output_len = length("$command_opt[$n][0]\/$command_opt[$n][1] $command_opt[$n][2]"); if ($max_opt_output_len <= $opt_output_len) { $max_opt_output_len = $opt_output_len; } } for ($n=0; $n<@command_opt; $n++) { $opt_output_str = "$command_opt[$n][0]\/$command_opt[$n][1] $command_opt[$n][2]"; print $opt_output_str; for ($j=0; $j<($max_opt_output_len-length($opt_output_str)); $j++) { print " "; } print " $command_opt[$n][3]\n"; } exit 1; } elsif ($opt_short_name eq '-b') { $rss_base_url = $ARGV[++$i]; } elsif ($opt_short_name eq '-B') { $base_directory = $ARGV[++$i]; } elsif ($opt_short_name eq '-d') { $rss_description = $ARGV[++$i]; } elsif ($opt_short_name eq '-g') { $rss_language = $ARGV[++$i]; } elsif ($opt_short_name eq '-l') { $rss_link = $ARGV[++$i]; } elsif ($opt_short_name eq '-r') { $requested_count = $ARGV[++$i]; } elsif ($opt_short_name eq '-t') { $rss_title = $ARGV[++$i]; } elsif ($opt_short_name eq '-f') { $mp4_format = $ARGV[++$i]; if ($mp4_format ne 'ipod' && $mp4_format ne 'psp') { print "Unkown MPEG4 format : $mp4_format !!\n"; exit 1; } } elsif ($opt_short_name eq '-s') { $title_regexp = $ARGV[++$i]; } else { $rss_file_name = $opt; } } if (length($rss_file_name) <= 0) { print "$script_name : Must specify a output RSS file name\n"; print "$script_name : try \'$script_name --help\' for more information \n"; exit 1 ; } print "$program_name (v$script_version), $copy_right\n"; print "Output RSS file name = $rss_file_name\n"; print " title : $rss_title\n"; print " description : $rss_description\n"; print " language : $rss_language\n"; print " base url : $rss_base_url\n"; print " base directory : $base_directory\n"; print " requested_count : $requested_count\n"; print " mp4_format : $mp4_format\n"; print " search regexp : $title_regexp\n"; #------------------------------ # main #------------------------------ my $obj = Net::UPnP::ControlPoint->new(); $retry_cnt = 0; @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { # @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:MediaServer:1', mx => 10); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); #@content_list = $mediaServer->getcontentlist(ObjectID => 0, RequestedCount => $requested_count); @content_list = $mediaServer->getcontentlist(ObjectID => 0); #print "content_list = @content_list\n"; foreach $content (@content_list) { parse_content_directory($mediaServer, $content); } $devNum++; } #------------------------------ # Output RSS file #------------------------------ if (@dms_content_list <= 0) { print "Couldn't find video contents !!\n"; exit 1; } $output_rss_filename = $base_directory . $rss_file_name; open(RSS_FILE, ">$output_rss_filename") || die "Couldn't open the specifed output file($output_rss_filename)\n"; $rss_header = <<"RSS_HEADER"; $rss_title $rss_language $rss_description $rss_link RSS_HEADER print RSS_FILE $rss_header; foreach $content (@dms_content_list){ $title = $content->{'title'}; $fname = $content->{'file_name'}; $fsize = $content->{'file_size'}; $mp4_link = $rss_base_url . $fname; $mp4_item = <<"RSS_MP4_ITEM"; $title $mp4_link RSS_MP4_ITEM print RSS_FILE $mp4_item; } $rss_footer = <<"RSS_FOOTER"; RSS_FOOTER print RSS_FILE $rss_footer; close(RSS_FILE); $rss_outputed_items = @dms_content_list; print "Outputed $rss_outputed_items RSS items to $output_rss_filename\n"; #------------------------------ # parse_content_directory #------------------------------ sub parse_content_directory { ($mediaServer, $content) = @_; my $objid = $content->getid(); if ($content->isitem()) { my $title = $content->gettitle(); my $mime = $content->getcontenttype(); if ( ($mime =~ m/video/) && ( (length($title_regexp) == 0) || ($title =~ m/$title_regexp/) ) ) { my $dms_content_count = @dms_content_list; if ($requested_count == 0 || $dms_content_count < $requested_count) { my $mp4_content = mpeg2tompeg4($mediaServer, $content); if (defined($mp4_content)) { push(@dms_content_list, $mp4_content); } } } } unless ($content->iscontainer()) { return; } my @child_content_list = $mediaServer->getcontentlist(ObjectID => $objid ); if (@child_content_list <= 0) { return; } foreach my $child_content (@child_content_list) { parse_content_directory($mediaServer, $child_content); } } #------------------------------ # mpeg2tompeg4 #------------------------------ sub mpeg2tompeg4 { ($mediaServer, $content) = @_; my $objid = $content->getid(); my $title = $content->gettitle(); my $url = $content->geturl(); print "[$objid] $title ($url)\n"; my $dev = $mediaServer->getdevice(); my $dev_friendlyname = $dev->getfriendlyname(); my $dev_udn = $dev->getudn(); $dev_udn =~ s/:/-/g; my $filename_body = $dev_friendlyname . "_" . $dev_udn . "_" . $objid; $filename_body =~ s/ //g; $filename_body =~ s/\//-/g; my $mpeg2_file_name = $filename_body . ".mpeg"; my $mpeg4_file_name = $filename_body . "_" . $mp4_format . ".m4v"; my $output_mpeg4_file_name = $base_directory . $mpeg4_file_name; if (!(-e $output_mpeg4_file_name)) { $curl_opt = "\"$url\" -o \"$mpeg2_file_name\""; print "curl $curl_opt\n"; curl($curl_opt); if ($mp4_format eq 'psp') { $ffmpeg_opt = "-y -i \"$mpeg2_file_name\" -bitexact -fixaspect -s 320x240 -r 29.97 -b 768 -ar 24000 -ab 32 -f psp \"$output_mpeg4_file_name\""; } else { $ffmpeg_opt = "-y -i \"$mpeg2_file_name\" -bitexact -fixaspect -s 320x240 -r 29.97 -b 850 -acodec aac -ac 2 -ar 44100 -ab 64 -f mp4 \"$output_mpeg4_file_name\""; } print "ffmpeg $ffmpeg_opt\n"; ffmpeg($ffmpeg_opt); unlink($mpeg2_file_name); } if (!(-e $output_mpeg4_file_name)) { return undef; } my $mpeg4_file_size = -s $output_mpeg4_file_name; if ($mpeg4_file_size <= 0) { return undef; } my %info = ( 'objid' => $objid, 'title' => $title, 'file_name' => $mpeg4_file_name, 'file_size' => $mpeg4_file_size, ); return \%info; } exit 0; Net-UPnP-1.4.3/examples/upnpavchk.pl000755 000765 000024 00000002432 12353466776 017740 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; Net::UPnP->SetDebug(1); my $obj = Net::UPnP::ControlPoint->new(); if (0< @ARGV) { $target_server_name = $ARGV[0]; } @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { my $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } my $friendlyname = $dev->getfriendlyname(); if (0 < length($target_server_name)) { unless ($friendlyname =~ $target_server_name) { next; } } my $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); my @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach my $content (@content_list) { get_contentlist($mediaServer, $content); } } sub get_contentlist { my ($mediaServer, $content) = @_; my $id = $content->getid(); my $title = $content->gettitle(); unless ($content->iscontainer()) { return; } my @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } foreach my $child_content (@child_content_list) { get_contentlist($mediaServer, $child_content); } } exit 0; Net-UPnP-1.4.3/examples/upnpavdump.pl000755 000765 000024 00000003565 12353466776 020150 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; use Net::UPnP::AV::MediaServer; my $obj = Net::UPnP::ControlPoint->new(); if (0< @ARGV) { $target_server_name = $ARGV[0]; } @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { # @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:MediaServer:1', mx => 10); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { my $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } my $friendlyname = $dev->getfriendlyname(); if (0 < length($target_server_name)) { unless ($friendlyname =~ $target_server_name) { next; } } print "[$devNum] : " . $friendlyname . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } my $mediaServer = Net::UPnP::AV::MediaServer->new(); $mediaServer->setdevice($dev); print "\tSystemUpdateID = " . $mediaServer->getsystemupdateid() . "\n"; my @content_list = $mediaServer->getcontentlist(ObjectID => 0); foreach my $content (@content_list) { print_content($mediaServer, $content, 1); } $devNum++; } sub print_content { my ($mediaServer, $content, $indent) = @_; my $id = $content->getid(); my $title = $content->gettitle(); for ($n=0; $n<$indent; $n++) { print "\t"; } print "$id = $title"; if ($content->isitem()) { print " (" . $content->geturl(); if (length($content->getdate())) { print " - " . $content->getdate(); } print " - " . $content->getcontenttype() . ")"; } print "\n"; unless ($content->iscontainer()) { return; } my @child_content_list = $mediaServer->getcontentlist(ObjectID => $id ); if (@child_content_list <= 0) { return; } $indent++; foreach my $child_content (@child_content_list) { print_content($mediaServer, $child_content, $indent); } } exit 0; Net-UPnP-1.4.3/examples/upnpavsimple.pl000755 000765 000024 00000002342 12353466776 020464 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) { next; } $condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1'); unless (defined(condir_service)) { next; } %action_in_arg = ( 'ObjectID' => 0, 'BrowseFlag' => 'BrowseDirectChildren', 'Filter' => '*', 'StartingIndex' => 0, 'RequestedCount' => 0, 'SortCriteria' => '', ); $action_res = $condir_service->postcontrol('Browse', \%action_in_arg); unless ($action_res->getstatuscode() == 200) { next; } $actrion_out_arg = $action_res->getargumentlist(); unless ($actrion_out_arg->{'Result'}) { next; } $result = $actrion_out_arg->{'Result'}; while ($result =~ m/(.*?)<\/dc:title>/sgi) { print "\t$1\n"; } $devNum++; } exit 0; Net-UPnP-1.4.3/examples/upnpchk.pl000755 000765 000024 00000000237 12353466776 017412 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; Net::UPnP->SetDebug(1); my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(); exit 0; Net-UPnP-1.4.3/examples/upnpdump.pl000755 000765 000024 00000001271 12353466776 017611 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = $obj->search(); $devNum = 1; foreach $dev (@dev_list) { print "[$devNum] : " . $dev->getfriendlyname() . "\n"; print "\tdeviceType = " . $dev->getdevicetype() . "\n"; print "\tlocation = " . $dev->getlocation() . "\n"; print "\tudn = " . $dev->getudn() . "\n"; @serviceList = $dev->getservicelist(); if (@serviceList < 0) { next; } print "\tserviceList = " . @serviceList . "\n"; $serviceNum = 1; foreach $service (@serviceList) { $service_type = $service->getservicetype(); print "\t\t[$serviceNum] = " . $service_type . "\n"; $serviceNum++; } $devNum++; } exit 0; Net-UPnP-1.4.3/examples/upnpgwdump.pl000755 000765 000024 00000002713 12353466776 020151 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; use Net::UPnP::GW::Gateway; my $obj = Net::UPnP::ControlPoint->new(); @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { # @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:InternetGatewayDevice:1', mx => 10); @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $devNum= 0; foreach $dev (@dev_list) { my $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') { next; } print "[$devNum] : " . $dev->getfriendlyname() . "\n"; unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) { next; } my $gwdev = Net::UPnP::GW::Gateway->new(); $gwdev->setdevice($dev); print "\tExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n"; print "\tPortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n"; print "\tTotalBytesRecived = " . $gwdev->gettotalbytesrecieved() . "\n"; @port_mapping = $gwdev->getportmappingentry(); $port_num = 0; foreach $port_entry (@port_mapping) { if ($port_entry) { $port_map_name = $port_entry->{'NewPortMappingDescription'}; if (length($port_map_name) <= 0) { $port_map_name = "(No name)"; } print " [$port_num] : $port_map_name\n"; foreach $name ( keys %{$port_entry} ) { print " $name = $port_entry->{$name}\n"; } } else { print " [$port_num] : Unknown\n"; } $port_num++; } } exit 0; Net-UPnP-1.4.3/examples/upnpgwtool.pl000755 000765 000024 00000007322 12353466776 020162 0ustar00skonnostaff000000 000000 #!/usr/local/bin/perl use Net::UPnP::ControlPoint; use Net::UPnP::GW::Gateway; #------------------------------ # functions #------------------------------ sub print_usages { print "usage : upnpgwtool command [args]\n"; print " command One of these\n"; print " search\n"; print " add \n"; print " delete \n"; print " list \n"; } sub check_command_line() { if (@ARGV < 1) { return 0; } $command = $ARGV[0]; if ($command eq "search") { return 1; } elsif ($command eq "list") { if (2 <= @ARGV) { return 1; } } elsif ($command eq "add") { if (7 <= @ARGV) { return 1; } } elsif ($command eq "delete") { if (4 <= @ARGV) { return 1; } } return 0; } #------------------------------ # main (pase command line) #------------------------------ if (!check_command_line()) { print_usages(); exit 1; } $ext_address = ""; if ($command eq "search") { $search_mode = 1; } elsif ($command eq "list") { $ext_address = $ARGV[1]; } elsif ($command eq "add") { $ext_address = $ARGV[3]; } elsif ($command eq "delete") { $ext_address = $ARGV[2]; } if (!$search_mode && length($ext_address) <= 0) { print_usages(); exit 1; } $obj = Net::UPnP::ControlPoint->new(); @dev_list = (); while (@dev_list <= 0 || $retry_cnt > 5) { @dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3); $retry_cnt++; } $gwdev_cnt = 0; foreach $dev (@dev_list) { $device_type = $dev->getdevicetype(); if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') { next; } unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) { next; } $gwdev = Net::UPnP::GW::Gateway->new(); $gwdev->setdevice($dev); $gwdev_ext_address = $gwdev->getexternalipaddress(); if ($search_mode) { $gwdev_friendlyname = $dev->getfriendlyname(); print "[$gwdev_cnt]:$gwdev_friendlyname ($gwdev_ext_address)\n"; $gwdev_cnt++; next; } if ($ext_address ne $gwdev_ext_address) { undef $gwdev; next; } last; } if ($command eq "search") { exit 0; } unless ($gwdev) { print "The specified gateway device ($ext_address) is not found !!"; exit 1; } $dev = $gwdev->getdevice(); print $dev->getfriendlyname() . "\n"; if ($command eq "list") { print " ExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n"; print " PortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n"; @port_mapping = $gwdev->getportmappingentry(); $port_num = 0; foreach $port_entry (@port_mapping) { if ($port_entry) { $port_map_name = $port_entry->{'NewPortMappingDescription'}; if (length($port_map_name) <= 0) { $port_map_name = "(No name)"; } print " [$port_num] : $port_map_name\n"; foreach $name ( keys %{$port_entry} ) { print " $name = $port_entry->{$name}\n"; } } else { print " [$port_num] : Unknown\n"; } $port_num++; } } elsif ($command eq "add") { print " $ARGV[1] $ext_address:$ARGV[4] => $ARGV[5]:$ARGV[6] ($ARGV[2])\n"; $action_ret = $gwdev->addportmapping( # NewRemoteHost => $ARGV[3], NewExternalPort => $ARGV[4], NewProtocol => $ARGV[2], NewInternalPort => $ARGV[6], NewInternalClient => $ARGV[5], NewPortMappingDescription => $ARGV[1]); if ($action_ret) { print " New port mapping is added\n"; } else { print " New port mapping is failed\n"; } } elsif ($command eq "delete") { print " $ARGV[2]:$ARGV[3] ($ARGV[1])\n"; $action_ret = $gwdev->addportmapping( # NewRemoteHost => $ARGV[2], NewExternalPort => $ARGV[3], NewProtocol => $ARGV[1]); if ($action_ret) { print " New port mapping is deleted\n"; } else { print " New port mapping is failed\n"; } } exit 0;