Commit 60e382ae68c0a082a732e54ff702ad12bc77f0b8 - libnet-upnp-perl

Import Upstream version 1.2.4 Damyan Ivanov 6 years ago

25 changed file(s) with 4211 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+68

-0

Changes less more

	0	Revision history for Perl extension UPnP.
	1
	2	2008-05-13 Satoshi Konno <skonno@cybergarage.org>
	3	* v1.2.4
	4
	5	2008-05-07 Christian KrauBe
	6	* Added Net::UPnP::GW::gettotalbytessent().
	7
	8	2008-05-01 Satoshi Konno <skonno@cybergarage.org>
	9	* Added Net::UPnP::GW::gettotalbytesrecieved().
	10	* Added a sample to use Net::UPnP::GW::gettotalbytesrecieved() into exsample/upnpgwdump.pl.
	11
	12	2006-03-13 Satoshi Konno <skonno@cybergarage.org>
	13	* v1.2.1
	14	* Added QueryResponse.pm to the package.
	15
	16	2006-03-02 Satoshi Konno <skonno@cybergarage.org>
	17	* v1.2
	18	* Renamed Net::UPnP::Service::postcontrol() to postaction(). The postcontrol() will be deprecated.
	19	* Added Net::UPnP::Service::postquery().
	20	* Added Net::UPnP::GW::Gateway to control IGD, Internet Gateway devices, such as broad band routers.
	21	* Added two example, upnpgwdump.pl and upnpgwtool, for Net::UPnP::GW.
	22	* Changed upnpavdump.pl to specify the target media server.
	23	* Fixed ActionResponse::getargumentlist() to remove extra attributes of the tag name.
	24
	25	2006-01-17 Satoshi Konno <skonno@cybergarage.org>
	26	* v1.1.3
	27	* Changed postcontrol() in Net::UPnP::Service to create the absolute control url normally using the url base and the relative control url.
	28	* Added '--search-title' option to selet the taget contents by the regular expression.
	29
	30	2005-12-20 Satoshi Konno <skonno@cybergarage.org>
	31	* v1.1.2
	32	* Changed Net::UPnP.pm to get the abstract normally.
	33
	34	2005-12-20 Satoshi Konno <skonno@cybergarage.org>
	35	* v1.1.1
	36	* Changed Net::UPnP::getdescription() to be able to specify the name.
	37	* Added some Net::UPnP::get*() to get the description value of the specified name.
	38	* Changed Net::Service::getdevicedescription() to be able to specify the name.
	39	* Fixed a test case bug in t/UPnP.t.
	40
	41	2005-12-10 Satoshi Konno <skonno@cybergarage.org>
	42
	43	* v1.1
	44	* Added 'use warnings' to all packages.
	45	* Changed to the package name from UPnP to Net::UPnP
	46	* Chanded get*() in Service.pm to return '' instead of undef when the value is not defined.
	47
	48	2005-12-09 Satoshi Konno <skonno@cybergarage.org>
	49
	50	* v1.0.3
	51	* Changed UPnP::AV::Item, UPnP::Device and Changed UPnP::HTTPResponse to parse the pod correctly.
	52
	53	2005-12-08 Satoshi Konno <skonno@cybergarage.org>
	54
	55	* v1.0.2
	56	* Changed dms2vodcast.pl to add a option for MPEG4 output format such as 'ipod' and 'psp'.
	57
	58	2005-12-07 Satoshi Konno <skonno@cybergarage.org>
	59
	60	* v1.0.1
	61	* Changed dms2vodcast.pl upnpavdump.pl to parse all items in the content directory.
	62	* Changed upnpavdump.pl to parse all items in the content directory.
	63
	64	2005-12-06 Satoshi Konno <skonno@cybergarage.org>
	65
	66	* The first release.
	67

+25

-0

MANIFEST less more

	0	Changes
	1	examples/dms2vodcast.pl
	2	examples/upnpavdump.pl
	3	examples/upnpavsimple.pl
	4	examples/upnpdump.pl
	5	examples/upnpgwdump.pl
	6	examples/upnpgwtool.pl
	7	lib/Net/UPnP.pm
	8	lib/Net/UPnP/ActionResponse.pm
	9	lib/Net/UPnP/AV/Container.pm
	10	lib/Net/UPnP/AV/Content.pm
	11	lib/Net/UPnP/AV/Item.pm
	12	lib/Net/UPnP/AV/MediaServer.pm
	13	lib/Net/UPnP/GW/Gateway.pm
	14	lib/Net/UPnP/ControlPoint.pm
	15	lib/Net/UPnP/Device.pm
	16	lib/Net/UPnP/HTTP.pm
	17	lib/Net/UPnP/HTTPResponse.pm
	18	lib/Net/UPnP/QueryResponse.pm
	19	lib/Net/UPnP/Service.pm
	20	Makefile.PL
	21	MANIFEST This list of files
	22	README
	23	t/UPnP.t
	24	META.yml Module meta-data (added by MakeMaker)

+10

-0

META.yml less more

	0	# http://module-build.sourceforge.net/META-spec.html
	1	#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
	2	name: Net-UPnP
	3	version: 1.2.4
	4	version_from: lib/Net/UPnP.pm
	5	installdirs: site
	6	requires:
	7
	8	distribution_type: module
	9	generated_by: ExtUtils::MakeMaker version 6.30

+12

-0

Makefile.PL less more

	0	use 5.008;
	1	use ExtUtils::MakeMaker;
	2	# See lib/ExtUtils/MakeMaker.pm for details of how to influence
	3	# the contents of the Makefile that is written.
	4	WriteMakefile(
	5	NAME => 'Net::UPnP',
	6	VERSION_FROM => 'lib/Net/UPnP.pm', # finds $VERSION
	7	PREREQ_PM => {}, # e.g., Module::Name => 1.1
	8	($] >= 5.005 ? ## Add these new keywords supported since 5.005
	9	(ABSTRACT_FROM => 'lib/Net/UPnP.pm', # retrieve abstract from module
	10	AUTHOR => 'skonno <skonno@cybergarage.org>') : ()),
	11	);

+54

-0

README less more

	0	Net::UPnP version 1.2.4
	1	===========================
	2
	3	The README is used to introduce the module and provide instructions on
	4	how to install the module, any machine dependencies it may have (for
	5	example C compilers and installed libraries) and any other information
	6	that should be provided before the module is installed.
	7
	8	A README file is required for CPAN modules since CPAN extracts the
	9	README file from a module distribution so that people browsing the
	10	archive can use it get an idea of the modules uses. It is usually a
	11	good idea to provide version information here so that people can
	12	decide whether fixes for the module are worth downloading.
	13
	14	INSTALLATION
	15
	16	To install this module type the following:
	17
	18	perl Makefile.PL
	19	make
	20	make test
	21	make install
	22
	23	COPYRIGHT AND LICENCE
	24
	25	Copyright (C) 2005-2008 Satoshi Konno
	26	All rights reserved.
	27
	28	Redistribution and use in source and binary forms, with or without
	29	modification, are permitted provided that the following conditions are met:
	30
	31	1. Redistributions of source code must retain the above copyright notice,
	32	this list of conditions and the following disclaimer.
	33
	34	2. Redistributions in binary form must reproduce the above copyright
	35	notice, this list of conditions and the following disclaimer in the documentation
	36	and/or other materials provided with the distribution.
	37
	38	3. The name of the author may not be used to endorse or promote
	39	products derived from this software without specific prior written permission.
	40
	41	THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
	42	IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
	43	WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
	44	PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
	45	ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
	46	DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
	47	GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
	48	INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
	49	WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
	50	OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
	51	EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
	52
	53

+332

-0

examples/dms2vodcast.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3	use Net::UPnP::AV::MediaServer;
	4
	5	use Shell qw(curl ffmpeg);
	6
	7	#curl('--version');
	8	#ffmpeg('-version');
	9
	10	#------------------------------
	11	# program info
	12	#------------------------------
	13
	14	$program_name = 'DLNA Media Sever 2 Vodcast';
	15	$copy_right = 'Copyright (c) 2005 Satoshi Konno';
	16	$script_name = 'dms2vodcast.pl';
	17	$script_version = '1.0.3';
	18
	19	#------------------------------
	20	# global variables
	21	#------------------------------
	22
	23	@dms_content_list = ();
	24
	25	#------------------------------
	26	# command option
	27	#------------------------------
	28
	29	$rss_file_name = "";
	30	$base_directory = "./";
	31	$rss_base_url= "http://localhost";
	32	$rss_description = "CyberGarage Vodcast";
	33	$rss_language = "";
	34	$rss_link= "";
	35	$rss_title = "CyberGarage";
	36	$requested_count = 0;
	37	$mp4_format = 'ipod';
	38	$title_regexp = "";
	39
	40	@command_opt = (
	41	['-b', '--base-url', '<url>', 'Set the base url in the item link property of the output RSS file'],
	42	['-B', '--base-directory', '<url>', 'Set the base directory to output the RSS file and the MPEG4 files'],
	43	['-d', '--rss-description', '<description>', 'Set the description tag in the output RSS file'],
	44	['-g', '--rss-language', '<language>', 'Set the language tag in the output RSS file'],
	45	['-h', '--help', '', 'This is help text.'],
	46	['-l', '--rss-link', '<link>', 'Set the link tag in the output RSS file'],
	47	['-r', '--requested-count', '<url>', 'Set the max request count to the media server contents'],
	48	['-t', '--rss-title', '<file>', 'Set the title tag in the output RSS file'],
	49	['-f', '--mp4-format', '<ipod \| psp>', 'Set the MPEG4 format'],
	50	['-s', '--search-title', '<regular expression>', 'Set the regular expression of the content titles by UTF-8'],
	51	);
	52
	53	sub is_command_option {
	54	($opt) = @_;
	55	for ($n=0; $n<@command_opt; $n++) {
	56	if ($opt eq $command_opt[$n][0] \|\| $opt eq $command_opt[$n][1]) {
	57	return $n;
	58	}
	59	}
	60	return -1;
	61	}
	62
	63	#------------------------------
	64	# main (pase command line)
	65	#------------------------------
	66
	67	for ($i=0; $i<(@ARGV); $i++) {
	68	$opt = $ARGV[$i];
	69	$opt_num = is_command_option($opt);
	70	$opt_short_name = '';
	71	if ($opt_num < 0) {
	72	if ($opt =~ m/^-/) {
	73	print "$script_name : option $opt is unknown\n";
	74	print "$script_name : try \'$script_name --help\' for more information \n";
	75	exit 1;
	76	}
	77	}
	78	else {
	79	$opt_short_name = $command_opt[$opt_num][0];
	80	}
	81	if ($opt_short_name eq '-h') {
	82	print "Usage : $script_name [options...] <output RSS file name>\n";
	83	print "Options : \n";
	84	$max_opt_output_len = 0;
	85	for ($n=0; $n<@command_opt; $n++) {
	86	$opt_output_len = length("$command_opt[$n][0]\/$command_opt[$n][1] $command_opt[$n][2]");
	87	if ($max_opt_output_len <= $opt_output_len) {
	88	$max_opt_output_len = $opt_output_len;
	89	}
	90	}
	91	for ($n=0; $n<@command_opt; $n++) {
	92	$opt_output_str = "$command_opt[$n][0]\/$command_opt[$n][1] $command_opt[$n][2]";
	93	print $opt_output_str;
	94	for ($j=0; $j<($max_opt_output_len-length($opt_output_str)); $j++) {
	95	print " ";
	96	}
	97	print " $command_opt[$n][3]\n";
	98	}
	99	exit 1;
	100	} elsif ($opt_short_name eq '-b') {
	101	$rss_base_url = $ARGV[++$i];
	102	} elsif ($opt_short_name eq '-B') {
	103	$base_directory = $ARGV[++$i];
	104	} elsif ($opt_short_name eq '-d') {
	105	$rss_description = $ARGV[++$i];
	106	} elsif ($opt_short_name eq '-g') {
	107	$rss_language = $ARGV[++$i];
	108	} elsif ($opt_short_name eq '-l') {
	109	$rss_link = $ARGV[++$i];
	110	} elsif ($opt_short_name eq '-r') {
	111	$requested_count = $ARGV[++$i];
	112	} elsif ($opt_short_name eq '-t') {
	113	$rss_title = $ARGV[++$i];
	114	} elsif ($opt_short_name eq '-f') {
	115	$mp4_format = $ARGV[++$i];
	116	if ($mp4_format ne 'ipod' && $mp4_format ne 'psp') {
	117	print "Unkown MPEG4 format : $mp4_format !!\n";
	118	exit 1;
	119	}
	120	} elsif ($opt_short_name eq '-s') {
	121	$title_regexp = $ARGV[++$i];
	122	} else {
	123	$rss_file_name = $opt;
	124	}
	125	}
	126
	127	if (length($rss_file_name) <= 0) {
	128	print "$script_name : Must specify a output RSS file name\n";
	129	print "$script_name : try \'$script_name --help\' for more information \n";
	130	exit 1 ;
	131	}
	132
	133	print "$program_name (v$script_version), $copy_right\n";
	134	print "Output RSS file name = $rss_file_name\n";
	135	print " title : $rss_title\n";
	136	print " description : $rss_description\n";
	137	print " language : $rss_language\n";
	138	print " base url : $rss_base_url\n";
	139	print " base directory : $base_directory\n";
	140	print " requested_count : $requested_count\n";
	141	print " mp4_format : $mp4_format\n";
	142	print " search regexp : $title_regexp\n";
	143
	144	#------------------------------
	145	# main
	146	#------------------------------
	147
	148	my $obj = Net::UPnP::ControlPoint->new();
	149
	150	$retry_cnt = 0;
	151	@dev_list = ();
	152	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	153	# @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:MediaServer:1', mx => 10);
	154	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	155	$retry_cnt++;
	156	}
	157
	158	$devNum= 0;
	159	foreach $dev (@dev_list) {
	160	$device_type = $dev->getdevicetype();
	161	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	162	next;
	163	}
	164	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	165	next;
	166	}
	167	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	168	$mediaServer = Net::UPnP::AV::MediaServer->new();
	169	$mediaServer->setdevice($dev);
	170	#@content_list = $mediaServer->getcontentlist(ObjectID => 0, RequestedCount => $requested_count);
	171	@content_list = $mediaServer->getcontentlist(ObjectID => 0);
	172	#print "content_list = @content_list\n";
	173	foreach $content (@content_list) {
	174	parse_content_directory($mediaServer, $content);
	175	}
	176	$devNum++;
	177	}
	178
	179	#------------------------------
	180	# Output RSS file
	181	#------------------------------
	182
	183	if (@dms_content_list <= 0) {
	184	print "Couldn't find video contents !!\n";
	185	exit 1;
	186	}
	187
	188	$output_rss_filename = $base_directory . $rss_file_name;
	189
	190	open(RSS_FILE, ">$output_rss_filename") \|\| die "Couldn't open the specifed output file($output_rss_filename)\n";
	191
	192	$rss_header = <<"RSS_HEADER";
	193	<?xml version="1.0" encoding="utf-8"?>
	194	<rss xmlns:itunes="http://www.itunes.com/DTDs/Podcast-1.0.dtd" version="2.0">
	195	<channel>
	196	<title>$rss_title</title>
	197	<language>$rss_language</language>
	198	<description>$rss_description</description>
	199	<link>$rss_link</link>
	200	RSS_HEADER
	201	print RSS_FILE $rss_header;
	202
	203	foreach $content (@dms_content_list){
	204	$title = $content->{'title'};
	205	$fname = $content->{'file_name'};
	206	$fsize = $content->{'file_size'};
	207
	208	$mp4_link = $rss_base_url . $fname;
	209	$mp4_item = <<"RSS_MP4_ITEM";
	210	<item>
	211	<title>$title</title>
	212	<guid isPermalink="false">$mp4_link</guid>
	213	<enclosure url="$mp4_link" length="$fsize" type="video/mp4" />
	214	</item>
	215	RSS_MP4_ITEM
	216	print RSS_FILE $mp4_item;
	217	}
	218
	219	$rss_footer = <<"RSS_FOOTER";
	220	</channel>
	221	</rss>
	222	RSS_FOOTER
	223	print RSS_FILE $rss_footer;
	224
	225	close(RSS_FILE);
	226
	227	$rss_outputed_items = @dms_content_list;
	228	print "Outputed $rss_outputed_items RSS items to $output_rss_filename\n";
	229
	230	#------------------------------
	231	# parse_content_directory
	232	#------------------------------
	233
	234	sub parse_content_directory {
	235	($mediaServer, $content) = @_;
	236	my $objid = $content->getid();
	237
	238	if ($content->isitem()) {
	239	my $title = $content->gettitle();
	240	my $mime = $content->getcontenttype();
	241	if ( ($mime =~ m/video/) && ( (length($title_regexp) == 0) \|\| ($title =~ m/$title_regexp/) ) ) {
	242	my $dms_content_count = @dms_content_list;
	243	if ($requested_count == 0 \|\| $dms_content_count < $requested_count) {
	244	my $mp4_content = mpeg2tompeg4($mediaServer, $content);
	245	if (defined($mp4_content)) {
	246	push(@dms_content_list, $mp4_content);
	247	}
	248	}
	249	}
	250	}
	251
	252	unless ($content->iscontainer()) {
	253	return;
	254	}
	255
	256	my @child_content_list = $mediaServer->getcontentlist(ObjectID => $objid );
	257
	258	if (@child_content_list <= 0) {
	259	return;
	260	}
	261
	262	foreach my $child_content (@child_content_list) {
	263	parse_content_directory($mediaServer, $child_content);
	264	}
	265	}
	266
	267	#------------------------------
	268	# mpeg2tompeg4
	269	#------------------------------
	270
	271	sub mpeg2tompeg4 {
	272	($mediaServer, $content) = @_;
	273	my $objid = $content->getid();
	274	my $title = $content->gettitle();
	275	my $url = $content->geturl();
	276
	277	print "[$objid] $title ($url)\n";
	278
	279	my $dev = $mediaServer->getdevice();
	280	my $dev_friendlyname = $dev->getfriendlyname();
	281	my $dev_udn = $dev->getudn();
	282	$dev_udn =~ s/:/-/g;
	283
	284	my $filename_body = $dev_friendlyname . "_" . $dev_udn . "_" . $objid;
	285	$filename_body =~ s/ //g;
	286	$filename_body =~ s/\//-/g;
	287
	288	my $mpeg2_file_name = $filename_body . ".mpeg";
	289	my $mpeg4_file_name = $filename_body . "_" . $mp4_format . ".m4v";
	290	my $output_mpeg4_file_name = $base_directory . $mpeg4_file_name;
	291
	292	if (!(-e $output_mpeg4_file_name)) {
	293	$curl_opt = "\"$url\" -o \"$mpeg2_file_name\"";
	294	print "curl $curl_opt\n";
	295	curl($curl_opt);
	296
	297	if ($mp4_format eq 'psp') {
	298	$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\"";
	299	}
	300	else {
	301	$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\"";
	302	}
	303
	304	print "ffmpeg $ffmpeg_opt\n";
	305	ffmpeg($ffmpeg_opt);
	306
	307	unlink($mpeg2_file_name);
	308	}
	309
	310	if (!(-e $output_mpeg4_file_name)) {
	311	return undef;
	312	}
	313
	314	my $mpeg4_file_size = -s $output_mpeg4_file_name;
	315
	316	if ($mpeg4_file_size <= 0) {
	317	return undef;
	318	}
	319
	320	my %info = (
	321	'objid' => $objid,
	322	'title' => $title,
	323	'file_name' => $mpeg4_file_name,
	324	'file_size' => $mpeg4_file_size,
	325	);
	326
	327	return \%info;
	328	}
	329
	330	exit 0;
	331

+83

-0

examples/upnpavdump.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3	use Net::UPnP::AV::MediaServer;
	4
	5	my $obj = Net::UPnP::ControlPoint->new();
	6
	7	if (0< @ARGV) {
	8	$target_server_name = $ARGV[0];
	9	}
	10
	11	@dev_list = ();
	12	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	13	# @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:MediaServer:1', mx => 10);
	14	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	15	$retry_cnt++;
	16	}
	17
	18	$devNum= 0;
	19	foreach $dev (@dev_list) {
	20	my $device_type = $dev->getdevicetype();
	21	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	22	next;
	23	}
	24	my $friendlyname = $dev->getfriendlyname();
	25	if (0 < length($target_server_name)) {
	26	unless ($friendlyname =~ $target_server_name) {
	27	next;
	28	}
	29	}
	30	print "[$devNum] : " . $friendlyname . "\n";
	31	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	32	next;
	33	}
	34	my $mediaServer = Net::UPnP::AV::MediaServer->new();
	35	$mediaServer->setdevice($dev);
	36
	37	print "\tSystemUpdateID = " . $mediaServer->getsystemupdateid() . "\n";
	38
	39	my @content_list = $mediaServer->getcontentlist(ObjectID => 0);
	40	foreach my $content (@content_list) {
	41	print_content($mediaServer, $content, 1);
	42	}
	43
	44	$devNum++;
	45	}
	46
	47	sub print_content {
	48	my ($mediaServer, $content, $indent) = @_;
	49	my $id = $content->getid();
	50	my $title = $content->gettitle();
	51
	52	for ($n=0; $n<$indent; $n++) {
	53	print "\t";
	54	}
	55	print "$id = $title";
	56	if ($content->isitem()) {
	57	print " (" . $content->geturl();
	58	if (length($content->getdate())) {
	59	print " - " . $content->getdate();
	60	}
	61	print " - " . $content->getcontenttype() . ")";
	62	}
	63	print "\n";
	64
	65	unless ($content->iscontainer()) {
	66	return;
	67	}
	68
	69	my @child_content_list = $mediaServer->getcontentlist(ObjectID => $id );
	70
	71	if (@child_content_list <= 0) {
	72	return;
	73	}
	74
	75	$indent++;
	76	foreach my $child_content (@child_content_list) {
	77	print_content($mediaServer, $child_content, $indent);
	78	}
	79	}
	80
	81	exit 0;
	82

+53

-0

examples/upnpavsimple.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3
	4	my $obj = Net::UPnP::ControlPoint->new();
	5
	6	@dev_list = ();
	7	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	8	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	9	$retry_cnt++;
	10	}
	11
	12	$devNum= 0;
	13	foreach $dev (@dev_list) {
	14	$device_type = $dev->getdevicetype();
	15	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	16	next;
	17	}
	18	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	19	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	20	next;
	21	}
	22	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	23	unless (defined(condir_service)) {
	24	next;
	25	}
	26	%action_in_arg = (
	27	'ObjectID' => 0,
	28	'BrowseFlag' => 'BrowseDirectChildren',
	29	'Filter' => '*',
	30	'StartingIndex' => 0,
	31	'RequestedCount' => 0,
	32	'SortCriteria' => '',
	33	);
	34
	35	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	36	unless ($action_res->getstatuscode() == 200) {
	37	next;
	38	}
	39	$actrion_out_arg = $action_res->getargumentlist();
	40	unless ($actrion_out_arg->{'Result'}) {
	41	next;
	42	}
	43	$result = $actrion_out_arg->{'Result'};
	44	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	45	print "\t$1\n";
	46	}
	47
	48	$devNum++;
	49	}
	50
	51	exit 0;
	52

+30

-0

examples/upnpdump.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3
	4	my $obj = Net::UPnP::ControlPoint->new();
	5
	6	@dev_list = $obj->search();
	7
	8	$devNum = 1;
	9	foreach $dev (@dev_list) {
	10	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	11	print "\tdeviceType = " . $dev->getdevicetype() . "\n";
	12	print "\tlocation = " . $dev->getlocation() . "\n";
	13	print "\tudn = " . $dev->getudn() . "\n";
	14	@serviceList = $dev->getservicelist();
	15	if (@serviceList < 0) {
	16	next;
	17	}
	18	print "\tserviceList = " . @serviceList . "\n";
	19	$serviceNum = 1;
	20	foreach $service (@serviceList) {
	21	$service_type = $service->getservicetype();
	22	print "\t\t[$serviceNum] = " . $service_type . "\n";
	23	$serviceNum++;
	24	}
	25	$devNum++;
	26	}
	27
	28	exit 0;
	29

+52

-0

examples/upnpgwdump.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3	use Net::UPnP::GW::Gateway;
	4
	5	my $obj = Net::UPnP::ControlPoint->new();
	6
	7	@dev_list = ();
	8	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	9	# @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:InternetGatewayDevice:1', mx => 10);
	10	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	11	$retry_cnt++;
	12	}
	13
	14	$devNum= 0;
	15	foreach $dev (@dev_list) {
	16	my $device_type = $dev->getdevicetype();
	17	if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') {
	18	next;
	19	}
	20	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	21	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) {
	22	next;
	23	}
	24	my $gwdev = Net::UPnP::GW::Gateway->new();
	25	$gwdev->setdevice($dev);
	26	print "\tExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n";
	27	print "\tPortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n";
	28	print "\tTotalBytesRecived = " . $gwdev->gettotalbytesrecieved() . "\n";
	29	@port_mapping = $gwdev->getportmappingentry();
	30	$port_num = 0;
	31	foreach $port_entry (@port_mapping) {
	32	if ($port_entry) {
	33	$port_map_name = $port_entry->{'NewPortMappingDescription'};
	34	if (length($port_map_name) <= 0) {
	35	$port_map_name = "(No name)";
	36	}
	37	print " [$port_num] : $port_map_name\n";
	38	foreach $name ( keys %{$port_entry} ) {
	39	print " $name = $port_entry->{$name}\n";
	40	}
	41	}
	42	else {
	43	print " [$port_num] : Unknown\n";
	44	}
	45	$port_num++;
	46	}
	47	}
	48
	49
	50	exit 0;
	51

+168

-0

examples/upnpgwtool.pl less more

	0	#!/usr/local/bin/perl
	1
	2	use Net::UPnP::ControlPoint;
	3	use Net::UPnP::GW::Gateway;
	4
	5	#------------------------------
	6	# functions
	7	#------------------------------
	8
	9	sub print_usages {
	10	print "usage : upnpgwtool command [args]\n";
	11	print " command One of these\n";
	12	print " search\n";
	13	print " add <description> <tcp\|udp> <external address> <external port> <internal address> <internal port>\n";
	14	print " delete <tcp\|udp> <external address> <external port>\n";
	15	print " list <external address>\n";
	16	}
	17
	18	sub check_command_line()
	19	{
	20	if (@ARGV < 1) {
	21	return 0;
	22	}
	23	$command = $ARGV[0];
	24	if ($command eq "search") {
	25	return 1;
	26	}
	27	elsif ($command eq "list") {
	28	if (2 <= @ARGV) {
	29	return 1;
	30	}
	31	}
	32	elsif ($command eq "add") {
	33	if (7 <= @ARGV) {
	34	return 1;
	35	}
	36	}
	37	elsif ($command eq "delete") {
	38	if (4 <= @ARGV) {
	39	return 1;
	40	}
	41	}
	42	return 0;
	43	}
	44
	45	#------------------------------
	46	# main (pase command line)
	47	#------------------------------
	48
	49	if (!check_command_line()) {
	50	print_usages();
	51	exit 1;
	52	}
	53
	54	$ext_address = "";
	55
	56	if ($command eq "search") {
	57	$search_mode = 1;
	58	} elsif ($command eq "list") {
	59	$ext_address = $ARGV[1];
	60	} elsif ($command eq "add") {
	61	$ext_address = $ARGV[3];
	62	} elsif ($command eq "delete") {
	63	$ext_address = $ARGV[2];
	64	}
	65
	66	if (!$search_mode && length($ext_address) <= 0) {
	67	print_usages();
	68	exit 1;
	69	}
	70
	71	$obj = Net::UPnP::ControlPoint->new();
	72
	73	@dev_list = ();
	74	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	75	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	76	$retry_cnt++;
	77	}
	78
	79	$gwdev_cnt = 0;
	80	foreach $dev (@dev_list) {
	81	$device_type = $dev->getdevicetype();
	82	if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') {
	83	next;
	84	}
	85	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) {
	86	next;
	87	}
	88	$gwdev = Net::UPnP::GW::Gateway->new();
	89	$gwdev->setdevice($dev);
	90	$gwdev_ext_address = $gwdev->getexternalipaddress();
	91	if ($search_mode) {
	92	$gwdev_friendlyname = $dev->getfriendlyname();
	93	print "[$gwdev_cnt]:$gwdev_friendlyname ($gwdev_ext_address)\n";
	94	$gwdev_cnt++;
	95	next;
	96	}
	97	if ($ext_address ne $gwdev_ext_address) {
	98	undef $gwdev;
	99	next;
	100	}
	101	last;
	102	}
	103
	104	if ($command eq "search") {
	105	exit 0;
	106	}
	107
	108	unless ($gwdev) {
	109	print "The specified gateway device ($ext_address) is not found !!";
	110	exit 1;
	111	}
	112
	113	$dev = $gwdev->getdevice();
	114	print $dev->getfriendlyname() . "\n";
	115
	116	if ($command eq "list") {
	117	print " ExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n";
	118	print " PortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n";
	119	@port_mapping = $gwdev->getportmappingentry();
	120	$port_num = 0;
	121	foreach $port_entry (@port_mapping) {
	122	if ($port_entry) {
	123	$port_map_name = $port_entry->{'NewPortMappingDescription'};
	124	if (length($port_map_name) <= 0) {
	125	$port_map_name = "(No name)";
	126	}
	127	print " [$port_num] : $port_map_name\n";
	128	foreach $name ( keys %{$port_entry} ) {
	129	print " $name = $port_entry->{$name}\n";
	130	}
	131	}
	132	else {
	133	print " [$port_num] : Unknown\n";
	134	}
	135	$port_num++;
	136	}
	137	} elsif ($command eq "add") {
	138	print " $ARGV[1] $ext_address:$ARGV[4] => $ARGV[5]:$ARGV[6] ($ARGV[2])\n";
	139	$action_ret = $gwdev->addportmapping(
	140	# NewRemoteHost => $ARGV[3],
	141	NewExternalPort => $ARGV[4],
	142	NewProtocol => $ARGV[2],
	143	NewInternalPort => $ARGV[6],
	144	NewInternalClient => $ARGV[5],
	145	NewPortMappingDescription => $ARGV[1]);
	146	if ($action_ret) {
	147	print " New port mapping is added\n";
	148	}
	149	else {
	150	print " New port mapping is failed\n";
	151	}
	152	} elsif ($command eq "delete") {
	153	print " $ARGV[2]:$ARGV[3] ($ARGV[1])\n";
	154	$action_ret = $gwdev->addportmapping(
	155	# NewRemoteHost => $ARGV[2],
	156	NewExternalPort => $ARGV[3],
	157	NewProtocol => $ARGV[1]);
	158	if ($action_ret) {
	159	print " New port mapping is deleted\n";
	160	}
	161	else {
	162	print " New port mapping is failed\n";
	163	}
	164	}
	165
	166	exit 0;
	167

+151

-0

lib/Net/UPnP/AV/Container.pm less more

	0	package Net::UPnP::AV::Container;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::AV::Container
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::AV::Content;
	10
	11	use vars qw(@ISA);
	12
	13	@ISA = qw(Net::UPnP::AV::Content);
	14
	15	#------------------------------
	16	# new
	17	#------------------------------
	18
	19	sub new {
	20	my($class) = shift;
	21	my($this) = $class->SUPER::new();
	22	bless $this, $class;
	23	}
	24
	25	#------------------------------
	26	# is*
	27	#------------------------------
	28
	29	sub iscontainer() {
	30	1;
	31	}
	32
	33	1;
	34
	35	=head1 NAME
	36
	37	Net::UPnP::AV::Container - Perl extension for UPnP.
	38
	39	=head1 SYNOPSIS
	40
	41	use Net::UPnP::ControlPoint;
	42	use Net::UPnP::AV::MediaServer;
	43
	44	my $obj = Net::UPnP::ControlPoint->new();
	45
	46	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	47
	48	$devNum= 0;
	49	foreach $dev (@dev_list) {
	50	$device_type = $dev->getdevicetype();
	51	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	52	next;
	53	}
	54	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	55	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	56	next;
	57	}
	58	$mediaServer = Net::UPnP::AV::MediaServer->new();
	59	$mediaServer->setdevice($dev);
	60	@content_list = $mediaServer->getcontentlist(ObjectID => 0);
	61	foreach $content (@content_list) {
	62	print_content($mediaServer, $content, 1);
	63	}
	64	$devNum++;
	65	}
	66
	67	sub print_content {
	68	my ($mediaServer, $content, $indent) = @_;
	69	my $id = $content->getid();
	70	my $title = $content->gettitle();
	71	for ($n=0; $n<$indent; $n++) {
	72	print "\t";
	73	}
	74	print "$id = $title";
	75	if ($content->isitem()) {
	76	print " (" . $content->geturl();
	77	if (length($content->getdate())) {
	78	print " - " . $content->getdate();
	79	}
	80	print " - " . $content->getcontenttype() . ")";
	81	}
	82	print "\n";
	83	unless ($content->iscontainer()) {
	84	return;
	85	}
	86	@child_content_list = $mediaServer->getcontentlist(ObjectID => $id );
	87	if (@child_content_list <= 0) {
	88	return;
	89	}
	90	$indent++;
	91	foreach my $child_content (@child_content_list) {
	92	print_content($mediaServer, $child_content, $indent);
	93	}
	94	}
	95
	96	=head1 DESCRIPTION
	97
	98	The package is a extention UPnP/AV media server, and a sub class of L<Net::UPnP::AV::Content>.
	99
	100	=head1 METHODS
	101
	102	=over 4
	103
	104	=item B<iscontainer> - Check if the content is a container.
	105
	106	$isContainer = $container->iscontainer();
	107
	108	Check if the content is a container.
	109
	110	=item B<getid> - Get the content ID.
	111
	112	$id = $item->getid();
	113
	114	Get the content ID.
	115
	116	=item B<gettitle> - Get the content title.
	117
	118	$title = $item->gettitle();
	119
	120	Get the content title.
	121
	122	=item B<getdate> - Get the content date.
	123
	124	$date = $item->getdate();
	125
	126	Get the content date.
	127
	128	=back
	129
	130	=head1 SEE ALSO
	131
	132	L<Net::UPnP::AV::Content>
	133
	134	L<Net::UPnP::AV::Item>
	135
	136	=head1 AUTHOR
	137
	138	Satoshi Konno
	139	skonno@cybergarage.org
	140
	141	CyberGarage
	142	http://www.cybergarage.org
	143
	144	=head1 COPYRIGHT AND LICENSE
	145
	146	Copyright (C) 2005 by Satoshi Konno
	147
	148	It may be used, redistributed, and/or modified under the terms of BSD License.
	149
	150	=cut

+203

-0

lib/Net/UPnP/AV/Content.pm less more

	0	package Net::UPnP::AV::Content;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::AV::Content
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use vars qw($_ID $_TITLE $_DATE);
	10
	11	$_ID = '_id';
	12	$_TITLE = '_title';
	13	$_DATE = '_date';
	14
	15	#------------------------------
	16	# new
	17	#------------------------------
	18
	19	sub new {
	20	my($class) = shift;
	21	my($this) = {
	22	$Net::UPnP::AV::Content::_ID => '',
	23	$Net::UPnP::AV::Content::_TITLE => '',
	24	$Net::UPnP::AV::Content::_DATE => '',
	25	};
	26	bless $this, $class;
	27	}
	28
	29	#------------------------------
	30	# id
	31	#------------------------------
	32
	33	sub setid() {
	34	my($this) = shift;
	35	if (@_) {
	36	$this->{$Net::UPnP::AV::Content::_ID} = $_[0];
	37	}
	38	}
	39
	40	sub getid() {
	41	my($this) = shift;
	42	$this->{$Net::UPnP::AV::Content::_ID};
	43	}
	44
	45	#------------------------------
	46	# title
	47	#------------------------------
	48
	49	sub settitle() {
	50	my($this) = shift;
	51	if (@_) {
	52	$this->{$Net::UPnP::AV::Content::_TITLE} = $_[0];
	53	}
	54	}
	55
	56	sub gettitle() {
	57	my($this) = shift;
	58	$this->{$Net::UPnP::AV::Content::_TITLE};
	59	}
	60
	61	#------------------------------
	62	# date
	63	#------------------------------
	64
	65	sub setdate() {
	66	my($this) = shift;
	67	if (@_) {
	68	$this->{$Net::UPnP::AV::Content::_DATE} = $_[0];
	69	}
	70	}
	71
	72	sub getdate() {
	73	my($this) = shift;
	74	$this->{$Net::UPnP::AV::Content::_DATE};
	75	}
	76
	77	#------------------------------
	78	# is*
	79	#------------------------------
	80
	81	sub iscontainer() {
	82	0;
	83	}
	84
	85	sub isitem() {
	86	0;
	87	}
	88
	89	1;
	90
	91	__END__
	92
	93	=head1 NAME
	94
	95	Net::UPnP::AV::Content - Perl extension for UPnP.
	96
	97	=head1 SYNOPSIS
	98
	99	use Net::UPnP::ControlPoint;
	100	use Net::UPnP::AV::MediaServer;
	101
	102	my $obj = Net::UPnP::ControlPoint->new();
	103
	104	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	105
	106	$devNum= 0;
	107	foreach $dev (@dev_list) {
	108	$device_type = $dev->getdevicetype();
	109	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	110	next;
	111	}
	112	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	113	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	114	next;
	115	}
	116	$mediaServer = Net::UPnP::AV::MediaServer->new();
	117	$mediaServer->setdevice($dev);
	118	@content_list = $mediaServer->getcontentlist(ObjectID => 0);
	119	foreach $content (@content_list) {
	120	print_content($mediaServer, $content, 1);
	121	}
	122	$devNum++;
	123	}
	124
	125	sub print_content {
	126	my ($mediaServer, $content, $indent) = @_;
	127	my $id = $content->getid();
	128	my $title = $content->gettitle();
	129	for ($n=0; $n<$indent; $n++) {
	130	print "\t";
	131	}
	132	print "$id = $title";
	133	if ($content->isitem()) {
	134	print " (" . $content->geturl();
	135	if (length($content->getdate())) {
	136	print " - " . $content->getdate();
	137	}
	138	print " - " . $content->getcontenttype() . ")";
	139	}
	140	print "\n";
	141	unless ($content->iscontainer()) {
	142	return;
	143	}
	144	@child_content_list = $mediaServer->getcontentlist(ObjectID => $id );
	145	if (@child_content_list <= 0) {
	146	return;
	147	}
	148	$indent++;
	149	foreach my $child_content (@child_content_list) {
	150	print_content($mediaServer, $child_content, $indent);
	151	}
	152	}
	153
	154	=head1 DESCRIPTION
	155
	156	The package is a extention UPnP/AV media server, and a super class of L<Net::UPnP::AV::Container> and L<Net::UPnP::AV::Item>.
	157
	158	=head1 METHODS
	159
	160	=over 4
	161
	162	=item B<getid> - Get the content ID.
	163
	164	$id = $item->getid();
	165
	166	Get the content ID.
	167
	168	=item B<gettitle> - Get the content title.
	169
	170	$title = $item->gettitle();
	171
	172	Get the content title.
	173
	174	=item B<getdate> - Get the content date.
	175
	176	$date = $item->getdate();
	177
	178	Get the content date.
	179
	180	=back
	181
	182	=head1 SEE ALSO
	183
	184	L<Net::UPnP::AV::Item>
	185
	186	L<Net::UPnP::AV::Container>
	187
	188	=head1 AUTHOR
	189
	190	Satoshi Konno
	191	skonno@cybergarage.org
	192
	193	CyberGarage
	194	http://www.cybergarage.org
	195
	196	=head1 COPYRIGHT AND LICENSE
	197
	198	Copyright (C) 2005 by Satoshi Konno
	199
	200	It may be used, redistributed, and/or modified under the terms of BSD License.
	201
	202	=cut

+202

-0

lib/Net/UPnP/AV/Item.pm less more

	0	package Net::UPnP::AV::Item;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::AV::Item
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::AV::Content;
	10
	11	use vars qw(@ISA $_URL $_CONTENTTYPE);
	12
	13	@ISA = qw(Net::UPnP::AV::Content);
	14
	15	$_URL = '_url';
	16	$_CONTENTTYPE = '_contenttype';
	17
	18	#------------------------------
	19	# new
	20	#------------------------------
	21
	22	sub new {
	23	my($class) = shift;
	24	my($this) = $class->SUPER::new();
	25	$this->{$Net::UPnP::AV::Item::_URL} = '';
	26	$this->{$Net::UPnP::AV::Item::_CONTENTTYPE} = '';
	27	bless $this, $class;
	28	}
	29
	30	#------------------------------
	31	# url
	32	#------------------------------
	33
	34	sub seturl() {
	35	my($this) = shift;
	36	if (@_) {
	37	$this->{$Net::UPnP::AV::Item::_URL} = $_[0];
	38	}
	39	}
	40
	41	sub geturl() {
	42	my($this) = shift;
	43	$this->{$Net::UPnP::AV::Item::_URL};
	44	}
	45
	46	#------------------------------
	47	# contenttype
	48	#------------------------------
	49
	50	sub setcontenttype() {
	51	my($this) = shift;
	52	if (@_) {
	53	$this->{$Net::UPnP::AV::Item::_CONTENTTYPE} = $_[0];
	54	}
	55	}
	56
	57	sub getcontenttype() {
	58	my($this) = shift;
	59	$this->{$Net::UPnP::AV::Item::_CONTENTTYPE};
	60	}
	61
	62	#------------------------------
	63	# is*
	64	#------------------------------
	65
	66	sub isitem() {
	67	1;
	68	}
	69
	70	1;
	71
	72	__END__
	73
	74	=head1 NAME
	75
	76	Net::UPnP::AV::Item - Perl extension for UPnP.
	77
	78	=head1 SYNOPSIS
	79
	80	use Net::UPnP::ControlPoint;
	81	use Net::UPnP::AV::MediaServer;
	82
	83	my $obj = Net::UPnP::ControlPoint->new();
	84
	85	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	86
	87	$devNum= 0;
	88	foreach $dev (@dev_list) {
	89	$device_type = $dev->getdevicetype();
	90	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	91	next;
	92	}
	93	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	94	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	95	next;
	96	}
	97	$mediaServer = Net::UPnP::AV::MediaServer->new();
	98	$mediaServer->setdevice($dev);
	99	@content_list = $mediaServer->getcontentlist(ObjectID => 0);
	100	foreach $content (@content_list) {
	101	print_content($mediaServer, $content, 1);
	102	}
	103	$devNum++;
	104	}
	105
	106	sub print_content {
	107	my ($mediaServer, $content, $indent) = @_;
	108	my $id = $content->getid();
	109	my $title = $content->gettitle();
	110	for ($n=0; $n<$indent; $n++) {
	111	print "\t";
	112	}
	113	print "$id = $title";
	114	if ($content->isitem()) {
	115	print " (" . $content->geturl();
	116	if (length($content->getdate())) {
	117	print " - " . $content->getdate();
	118	}
	119	print " - " . $content->getcontenttype() . ")";
	120	}
	121	print "\n";
	122	unless ($content->iscontainer()) {
	123	return;
	124	}
	125	@child_content_list = $mediaServer->getcontentlist(ObjectID => $id );
	126	if (@child_content_list <= 0) {
	127	return;
	128	}
	129	$indent++;
	130	foreach my $child_content (@child_content_list) {
	131	print_content($mediaServer, $child_content, $indent);
	132	}
	133	}
	134
	135	=head1 DESCRIPTION
	136
	137	The package is a extention UPnP/AV media server, and a sub class of L<Net::UPnP::AV::Content>.
	138
	139	=head1 METHODS
	140
	141	=over 4
	142
	143	=item B<isitem> - Check if the content is a item.
	144
	145	$isItem = $item->isisitem();
	146
	147	Check if the content is a item.
	148
	149	=item B<getid> - Get the content ID.
	150
	151	$id = $item->getid();
	152
	153	Get the content ID.
	154
	155	=item B<gettitle> - Get the content title.
	156
	157	$title = $item->gettitle();
	158
	159	Get the content title.
	160
	161	=item B<getdate> - Get the content date.
	162
	163	$date = $item->getdate();
	164
	165	Get the content date.
	166
	167	=item B<geturl> - get the content URL
	168
	169	$url = $item->getcontenttype();
	170
	171	Get the content URL.
	172
	173	=item B<getcontenttype> - get the content type
	174
	175	$content_type = $item->getcontenttype();
	176
	177	Get the content type.
	178
	179	=back
	180
	181	=head1 SEE ALSO
	182
	183	L<Net::UPnP::AV::Content>
	184
	185	L<Net::UPnP::AV::Container>
	186
	187	=head1 AUTHOR
	188
	189	Satoshi Konno
	190	skonno@cybergarage.org
	191
	192	CyberGarage
	193	http://www.cybergarage.org
	194
	195	=head1 COPYRIGHT AND LICENSE
	196
	197	Copyright (C) 2005 by Satoshi Konno
	198
	199	It may be used, redistributed, and/or modified under the terms of BSD License.
	200
	201	=cut

+376

-0

lib/Net/UPnP/AV/MediaServer.pm less more

	0	package Net::UPnP::AV::MediaServer;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::AV::MediaServer
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::HTTP;
	10	use Net::UPnP::Device;
	11	use Net::UPnP::Service;
	12	use Net::UPnP::AV::Container;
	13	use Net::UPnP::AV::Item;
	14
	15	use vars qw($_DEVICE $DEVICE_TYPE $CONTENTDIRECTORY_SERVICE_TYPE);
	16
	17	$_DEVICE = 'device';
	18
	19	$DEVICE_TYPE = 'urn:schemas-upnp-org:device:MediaServer:1';
	20	$CONTENTDIRECTORY_SERVICE_TYPE = 'urn:schemas-upnp-org:service:ContentDirectory:1';
	21
	22	#------------------------------
	23	# new
	24	#------------------------------
	25
	26	sub new {
	27	my($class) = shift;
	28	my($this) = {
	29	$Net::UPnP::AV::MediaServer::_DEVICE => undef,
	30	};
	31	bless $this, $class;
	32	}
	33
	34	#------------------------------
	35	# device
	36	#------------------------------
	37
	38	sub setdevice() {
	39	my($this) = shift;
	40	if (@_) {
	41	$this->{$Net::UPnP::AV::MediaServer::_DEVICE} = $_[0];
	42	}
	43	}
	44
	45	sub getdevice() {
	46	my($this) = shift;
	47	$this->{$Net::UPnP::AV::MediaServer::_DEVICE};
	48	}
	49
	50	#------------------------------
	51	# browse
	52	#------------------------------
	53
	54	sub browse {
	55	my($this) = shift;
	56	my %args = (
	57	ObjectID => 0,
	58	BrowseFlag => 'BrowseDirectChildren',
	59	Filter => '*',
	60	StartingIndex => 0,
	61	RequestedCount => 0,
	62	SortCriteria => '',
	63	@_,
	64	);
	65
	66	my ($objid, $browseFlag, $filter, $startIdx, $reqCount, $sortCriteria) = @_;
	67	my (
	68	$dev,
	69	$condir_service,
	70	%req_arg,
	71	$action_res,
	72	);
	73
	74	$dev = $this->getdevice();
	75	$condir_service = $dev->getservicebyname($Net::UPnP::AV::MediaServer::CONTENTDIRECTORY_SERVICE_TYPE);
	76
	77	%req_arg = (
	78	'ObjectID' => $args{ObjectID},
	79	'BrowseFlag' => $args{BrowseFlag},
	80	'Filter' => $args{Filter},
	81	'StartingIndex' => $args{StartingIndex},
	82	'RequestedCount' => $args{RequestedCount},
	83	'SortCriteria' => $args{SortCriteria},
	84	);
	85
	86	$condir_service->postaction("Browse", \%req_arg);
	87	}
	88
	89	sub browsedirectchildren {
	90	my($this) = shift;
	91	my %args = (
	92	ObjectID => 0,
	93	Filter => '*',
	94	StartingIndex => 0,
	95	RequestedCount => 0,
	96	SortCriteria => '',
	97	@_,
	98	);
	99	$this->browse (
	100	ObjectID => $args{ObjectID},
	101	BrowseFlag => 'BrowseDirectChildren',
	102	Filter => $args{Filter},
	103	StartingIndex => $args{StartingIndex},
	104	RequestedCount => $args{RequestedCount},
	105	SortCriteria => $args{SortCriteria}
	106	);
	107	}
	108
	109	sub browsemetadata {
	110	my($this) = shift;
	111	my %args = (
	112	ObjectID => 0,
	113	Filter => '*',
	114	StartingIndex => 0,
	115	RequestedCount => 0,
	116	SortCriteria => '',
	117	@_,
	118	);
	119	$this->browse (
	120	ObjectID => $args{ObjectID},
	121	BrowseFlag => 'BrowseMetadata',
	122	Filter => $args{Filter},
	123	StartingIndex => $args{StartingIndex},
	124	RequestedCount => $args{RequestedCount},
	125	SortCriteria => $args{SortCriteria}
	126	);
	127	}
	128
	129	#------------------------------
	130	# getdirectchildren
	131	#------------------------------
	132
	133	sub getcontentlist {
	134	my($this) = shift;
	135	my %args = (
	136	ObjectID => 0,
	137	Filter => '*',
	138	StartingIndex => 0,
	139	RequestedCount => 0,
	140	SortCriteria => '',
	141	@_,
	142	);
	143	my (
	144	@content_list,
	145	$action_res,
	146	$arg_list,
	147	$result,
	148	$content,
	149	$container,
	150	$item,
	151	);
	152
	153	@content_list = ();
	154	$action_res = $this->browsedirectchildren(
	155	ObjectID => $args{ObjectID},
	156	Filter => $args{Filter},
	157	StartingIndex => $args{StartingIndex},
	158	RequestedCount => $args{RequestedCount},
	159	SortCriteria => $args{SortCriteria}
	160	);
	161	if ($action_res->getstatuscode() != 200) {
	162	return @content_list;
	163	}
	164	$arg_list = $action_res->getargumentlist();
	165	unless ($arg_list->{'Result'}) {
	166	return @content_list;
	167	}
	168	$result = $arg_list->{'Result'};
	169
	170	while ($result =~ m/<container(.*?)<\/container>/sgi) {
	171	$content = $1;
	172	$container = Net::UPnP::AV::Container->new();
	173	if ($content =~ m/id=\"(.*?)\"/si) {
	174	$container->setid($1);
	175	}
	176	if ($content =~ m/<dc:title>(.*)<\/dc:title>/si) {
	177	$container->settitle($1);
	178	}
	179	if ($content =~ m/<dc:date>(.*)<\/dc:date>/si) {
	180	$container->setdate($1);
	181	}
	182	push (@content_list, $container);
	183	#print "container(" . $container->getid() . ") = " . $container->gettitle() . "\n";
	184	#print $1;
	185	}
	186
	187	while ($result =~ m/<item(.*?)<\/item>/sgi) {
	188	$content = $1;
	189	$item= Net::UPnP::AV::Item->new();
	190	if ($content =~ m/id=\"(.*?)\"/si) {
	191	$item->setid($1);
	192	}
	193	if ($content =~ m/<dc:title>(.*)<\/dc:title>/si) {
	194	$item->settitle($1);
	195	}
	196	if ($content =~ m/<dc:date>(.*)<\/dc:date>/si) {
	197	$item->setdate($1);
	198	}
	199	if ($content =~ m/<res[^>]>(.?)<\/res>/si) {
	200	$item->seturl(Net::UPnP::HTTP::xmldecode($1));
	201	}
	202	if ($content =~ m/protocolInfo=\"http-get:[^:]:([^:]):.*\"/si) {
	203	$item->setcontenttype($1);
	204	}
	205	elsif ($content =~ m/protocolInfo=\"[^:]:[^:]:([^:]):.*\"/si) {
	206	$item->setcontenttype($1);
	207	}
	208	push (@content_list, $item);
	209	}
	210
	211	@content_list;
	212	}
	213
	214	#------------------------------
	215	# getsystemupdateid
	216	#------------------------------
	217
	218	sub getsystemupdateid {
	219	my($this) = shift;
	220
	221	my (
	222	$dev,
	223	$condir_service,
	224	$query_res,
	225	);
	226
	227	$dev = $this->getdevice();
	228	$condir_service = $dev->getservicebyname($Net::UPnP::AV::MediaServer::CONTENTDIRECTORY_SERVICE_TYPE);
	229
	230	$query_res = $condir_service->postquery("SystemUpdateID");
	231
	232	if ($query_res->getstatuscode() != 200) {
	233	return "";
	234	}
	235
	236	return $query_res->getvalue();
	237	}
	238
	239	1;
	240
	241	__END__
	242
	243	=head1 NAME
	244
	245	Net::UPnP::AV::MediaServer - Perl extension for UPnP.
	246
	247	=head1 SYNOPSIS
	248
	249	use Net::UPnP::ControlPoint;
	250	use Net::UPnP::AV::MediaServer;
	251
	252	my $obj = Net::UPnP::ControlPoint->new();
	253
	254	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	255
	256	$devNum= 0;
	257	foreach $dev (@dev_list) {
	258	$device_type = $dev->getdevicetype();
	259	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	260	next;
	261	}
	262	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	263	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	264	next;
	265	}
	266	$mediaServer = Net::UPnP::AV::MediaServer->new();
	267	$mediaServer->setdevice($dev);
	268	@content_list = $mediaServer->getcontentlist(ObjectID => 0);
	269	foreach $content (@content_list) {
	270	print_content($mediaServer, $content, 1);
	271	}
	272	$devNum++;
	273	}
	274
	275	sub print_content {
	276	my ($mediaServer, $content, $indent) = @_;
	277	my $id = $content->getid();
	278	my $title = $content->gettitle();
	279	for ($n=0; $n<$indent; $n++) {
	280	print "\t";
	281	}
	282	print "$id = $title";
	283	if ($content->isitem()) {
	284	print " (" . $content->geturl();
	285	if (length($content->getdate())) {
	286	print " - " . $content->getdate();
	287	}
	288	print " - " . $content->getcontenttype() . ")";
	289	}
	290	print "\n";
	291	unless ($content->iscontainer()) {
	292	return;
	293	}
	294	@child_content_list = $mediaServer->getcontentlist(ObjectID => $id );
	295	if (@child_content_list <= 0) {
	296	return;
	297	}
	298	$indent++;
	299	foreach my $child_content (@child_content_list) {
	300	print_content($mediaServer, $child_content, $indent);
	301	}
	302	}
	303
	304	=head1 DESCRIPTION
	305
	306	The package is a extention UPnP/AV media server.
	307
	308	=head1 METHODS
	309
	310	=over 4
	311
	312	=item B<new> - create new Net::UPnP::AV::MediaServer.
	313
	314	$mservier = Net::UPnP::AV::MediaServer();
	315
	316	Creates a new object. Read `perldoc perlboot` if you don't understand that.
	317
	318	The new object is not associated with any UPnP devices. Please use setdevice() to set the device.
	319
	320	=item B<setdevice> - set a UPnP devices
	321
	322	$mservier->setdevice($dev);
	323
	324	Set a device to the object.
	325
	326	=item B<browse> - browse the content directory.
	327
	328	@action_response = $mservier->browse(
	329	ObjectID => $objid, # 0
	330	BrowseFlag => $browseFlag, # 'BrowseDirectChildren'
	331	Filter => $filter, # "*'
	332	StartingIndex => $startIndex, # 0
	333	RequestedCount => $reqCount, # 0
	334	SortCriteria => $sortCrit # ''
	335	);
	336
	337	Browse the content directory and return the action response, L<Net::UPnP::ActionResponse>.
	338
	339	=item B<getcontentlist> - get the content list.
	340
	341	@content_list = $mservier->getcontentlist(
	342	ObjectID => $objid, # 0
	343	Filter => $filter, # "*'
	344	StartingIndex => $startIndex, # 0
	345	RequestedCount => $reqCount, # 0
	346	SortCriteria => $sortCrit # ''
	347	);
	348
	349	Browse the content directory and return the content list. Please see L<Net::UPnP::AV::Content>, L<Net::UPnP::AV::Item> and L<Net::UPnP::AV::Container>.
	350
	351	=back
	352
	353	=head1 SEE ALSO
	354
	355	L<Net::UPnP::AV::Content>
	356
	357	L<Net::UPnP::AV::Item>
	358
	359	L<Net::UPnP::AV::Container>
	360
	361	=head1 AUTHOR
	362
	363	Satoshi Konno
	364	skonno@cybergarage.org
	365
	366	CyberGarage
	367	http://www.cybergarage.org
	368
	369	=head1 COPYRIGHT AND LICENSE
	370
	371	Copyright (C) 2005 by Satoshi Konno
	372
	373	It may be used, redistributed, and/or modified under the terms of BSD License.
	374
	375	=cut

+215

-0

lib/Net/UPnP/ActionResponse.pm less more

	0	package Net::UPnP::ActionResponse;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::ActionResponse
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::HTTP;
	10	use Net::UPnP::HTTPResponse;
	11
	12	use vars qw($_HTTP_RESPONSE);
	13
	14	$_HTTP_RESPONSE = 'httpres';
	15
	16	#------------------------------
	17	# new
	18	#------------------------------
	19
	20	sub new {
	21	my($class) = shift;
	22	my($this) = {
	23	$Net::UPnP::ActionResponse::_HTTP_RESPONSE => undef,
	24	};
	25	bless $this, $class;
	26	}
	27
	28	#------------------------------
	29	# header
	30	#------------------------------
	31
	32	sub sethttpresponse() {
	33	my($this) = shift;
	34	$this->{$Net::UPnP::ActionResponse::_HTTP_RESPONSE} = $_[0];
	35	}
	36
	37	sub gethttpresponse() {
	38	my($this) = shift;
	39	$this->{$Net::UPnP::ActionResponse::_HTTP_RESPONSE};
	40	}
	41
	42	#------------------------------
	43	# status
	44	#------------------------------
	45
	46	sub getstatus() {
	47	my($this) = shift;
	48	my($http_res) = $this->gethttpresponse();
	49	$http_res->getstatus();
	50	}
	51
	52	sub getstatuscode() {
	53	my($this) = shift;
	54	my($http_res) = $this->gethttpresponse();
	55	$http_res->getstatuscode();
	56	}
	57
	58	#------------------------------
	59	# header
	60	#------------------------------
	61
	62	sub getheader() {
	63	my($this) = shift;
	64	my($http_res) = $this->gethttpresponse();
	65	$http_res->getheader();
	66	}
	67
	68	#------------------------------
	69	# content
	70	#------------------------------
	71
	72	sub getcontent() {
	73	my($this) = shift;
	74	my($http_res) = $this->gethttpresponse();
	75	$http_res->getcontent();
	76	}
	77
	78	#------------------------------
	79	# content
	80	#------------------------------
	81
	82	sub getargumentlist() {
	83	my($this) = shift;
	84	my(
	85	$http_res,
	86	%argument_list,
	87	$res_statcode,
	88	$res_content,
	89	$soap_response,
	90	$arg_name,
	91	$arg_value,
	92	@arg_name_token,
	93	);
	94
	95	%argument_list = ();
	96
	97	$http_res = $this->gethttpresponse();
	98
	99	$res_statcode = $http_res->getstatuscode();
	100	if ($res_statcode != 200) {
	101	return \%argument_list;
	102	}
	103
	104	$res_content = $http_res->getcontent();
	105	if ($res_content =~ m/<.Response[^>]>\s(.)\s<\/.Response>/si) {
	106	$soap_response = $1;
	107	}
	108
	109	while ($soap_response =~ m/<([^>])>([^<])<\/[^>]*>/sg) {
	110	$arg_name = $1;
	111	if (0 < index($arg_name, ' ')) {
	112	@arg_name_token = split(/ /, $arg_name);
	113	if (0 < @arg_name_token) {
	114	$arg_name = $arg_name_token[0];
	115	}
	116	}
	117	$arg_value = $2;
	118	$arg_value = Net::UPnP::HTTP::xmldecode($arg_value);
	119	$argument_list{$arg_name} = $arg_value;
	120	}
	121
	122	return \%argument_list;
	123	}
	124
	125	1;
	126
	127	__END__
	128
	129	=head1 NAME
	130
	131	Net::UPnP::ActionResponse - Perl extension for UPnP.
	132
	133	=head1 SYNOPSIS
	134
	135	use Net::UPnP::ControlPoint;
	136
	137	my $obj = Net::UPnP::ControlPoint->new();
	138
	139	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	140
	141	$devNum= 0;
	142	foreach $dev (@dev_list) {
	143	$device_type = $dev->getdevicetype();
	144	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	145	next;
	146	}
	147	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	148	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	149	next;
	150	}
	151	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	152	unless (defined(condir_service)) {
	153	next;
	154	}
	155	%action_in_arg = (
	156	'ObjectID' => 0,
	157	'BrowseFlag' => 'BrowseDirectChildren',
	158	'Filter' => '*',
	159	'StartingIndex' => 0,
	160	'RequestedCount' => 0,
	161	'SortCriteria' => '',
	162	);
	163	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	164	unless ($action_res->getstatuscode() == 200) {
	165	next;
	166	}
	167	$actrion_out_arg = $action_res->getargumentlist();
	168	unless ($actrion_out_arg->{'Result'}) {
	169	next;
	170	}
	171	$result = $actrion_out_arg->{'Result'};
	172	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	173	print "\t$1\n";
	174	}
	175	$devNum++;
	176	}
	177
	178	=head1 DESCRIPTION
	179
	180	The package is used a object of the action response.
	181
	182	=head1 METHODS
	183
	184	=over 4
	185
	186	=item B<getstatuscode> - get the status code.
	187
	188	$status_code = $actionres->getstatuscode();
	189
	190	Get the status code of the SOAP response.
	191
	192	=item B<getargumentlist> - get the argument list.
	193
	194	\%argument_list = $actionres->getargumentlist();
	195
	196	Get the argument list of the SOAP response.
	197
	198	=back
	199
	200	=head1 AUTHOR
	201
	202	Satoshi Konno
	203	skonno@cybergarage.org
	204
	205	CyberGarage
	206	http://www.cybergarage.org
	207
	208	=head1 COPYRIGHT AND LICENSE
	209
	210	Copyright (C) 2005 by Satoshi Konno
	211
	212	It may be used, redistributed, and/or modified under the terms of BSD License.
	213
	214	=cut

+222

-0

lib/Net/UPnP/ControlPoint.pm less more

	0	package Net::UPnP::ControlPoint;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::ControlPoint
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Socket;
	10
	11	use Net::UPnP;
	12	use Net::UPnP::HTTP;
	13	use Net::UPnP::Device;
	14
	15	#------------------------------
	16	# new
	17	#------------------------------
	18
	19	sub new {
	20	my($class) = shift;
	21	my($this) = {};
	22	bless $this, $class;
	23	}
	24
	25	#------------------------------
	26	# search
	27	#------------------------------
	28
	29	sub search {
	30	my($this) = shift;
	31	my %args = (
	32	st => 'upnp:rootdevice',
	33	mx => 3,
	34	@_,
	35	);
	36	my(
	37	@dev_list,
	38	$ssdp_header,
	39	$ssdp_mcast,
	40	$rin,
	41	$rout,
	42	$ssdp_res_msg,
	43	$dev_location,
	44	$dev_addr,
	45	$dev_port,
	46	$dev_path,
	47	$dev_friendly_name,
	48	$http_req,
	49	$post_res,
	50	$post_content,
	51	$key,
	52	$dev,
	53	);
	54
	55	$ssdp_header = <<"SSDP_SEARCH_MSG";
	56	M-SEARCH * HTTP/1.1
	57	Host: $Net::UPnP::SSDP_ADDR:$Net::UPnP::SSDP_PORT
	58	Man: "ssdp:discover"
	59	ST: $args{st}
	60	MX: $args{mx}
	61
	62	SSDP_SEARCH_MSG
	63
	64	$ssdp_header =~ s/\r//g;
	65	$ssdp_header =~ s/\n/\r\n/g;
	66
	67	socket(SSDP_SOCK, AF_INET, SOCK_DGRAM, getprotobyname('udp'));
	68	$ssdp_mcast = sockaddr_in($Net::UPnP::SSDP_PORT, inet_aton($Net::UPnP::SSDP_ADDR));
	69
	70	send(SSDP_SOCK, $ssdp_header, 0, $ssdp_mcast);
	71
	72	if ($Net::UPnP::DEBUG) {
	73	print "$ssdp_header\n";
	74	}
	75
	76	@dev_list = ();
	77
	78	$rin = '';
	79	vec($rin, fileno(SSDP_SOCK), 1) = 1;
	80	while( select($rout = $rin, undef, undef, ($args{mx} * 2)) ) {
	81	recv(SSDP_SOCK, $ssdp_res_msg, 4096, 0);
	82
	83	print "$ssdp_res_msg" if ($Net::UPnP::DEBUG);
	84
	85	unless ($ssdp_res_msg =~ m/LOCATION[ :]+(.*)\r/i) {
	86	next;
	87	}
	88	$dev_location = $1;
	89	unless ($dev_location =~ m/http:\/\/([0-9a-z.]+)[:]([0-9])\/(.*)/i) {
	90	next;
	91	}
	92	$dev_addr = $1;
	93	$dev_port = $2;
	94	$dev_path = '/' . $3;
	95
	96	$http_req = Net::UPnP::HTTP->new();
	97	$post_res = $http_req->post($dev_addr, $dev_port, "GET", $dev_path, "", "");
	98
	99	if ($Net::UPnP::DEBUG) {
	100	print $post_res->getstatus() . "\n";
	101	print $post_res->getheader() . "\n";
	102	print $post_res->getcontent() . "\n";
	103	}
	104
	105	$post_content = $post_res->getcontent();
	106
	107	$dev = Net::UPnP::Device->new();
	108	$dev->setssdp($ssdp_res_msg);
	109	$dev->setdescription($post_content);
	110
	111	if ($Net::UPnP::DEBUG) {
	112	print "friendlyName = $dev_friendly_name\n";
	113	print "ssdp = $ssdp_res_msg\n";
	114	print "description = $post_content\n";
	115	}
	116
	117	push(@dev_list, $dev);
	118
	119	}
	120
	121	close(SSDP_SOCK);
	122
	123	@dev_list;
	124	}
	125
	126	1;
	127
	128	__END__
	129
	130	=head1 NAME
	131
	132	Net::UPnP::ControlPoint - Perl extension for UPnP control point.
	133
	134	=head1 SYNOPSIS
	135
	136	use Net::UPnP::ControlPoint;
	137
	138	my $obj = Net::UPnP::ControlPoint->new();
	139
	140	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	141
	142	$devNum= 0;
	143	foreach $dev (@dev_list) {
	144	$device_type = $dev->getdevicetype();
	145	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	146	next;
	147	}
	148	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	149	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	150	next;
	151	}
	152	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	153	unless (defined(condir_service)) {
	154	next;
	155	}
	156	%action_in_arg = (
	157	'ObjectID' => 0,
	158	'BrowseFlag' => 'BrowseDirectChildren',
	159	'Filter' => '*',
	160	'StartingIndex' => 0,
	161	'RequestedCount' => 0,
	162	'SortCriteria' => '',
	163	);
	164	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	165	$actrion_out_arg = $action_res->getargumentlist();
	166	unless ($actrion_out_arg->{'Result'}) {
	167	next;
	168	}
	169	$result = $actrion_out_arg->{'Result'};
	170	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	171	print "\t$1\n";
	172	}
	173	$devNum++;
	174	}
	175
	176	=head1 DESCRIPTION
	177
	178	The package can search UPnP devices in the local network and get the device list of L<Net::UPnP::Device>.
	179
	180	=head1 METHODS
	181
	182	=over 4
	183
	184	=item B<new> - create new Net::UPnP::ControlPoint
	185
	186	$ctrlPoint = Net::UPnP::ControlPoint();
	187
	188	Creates a new object. Read `perldoc perlboot` if you don't understand that.
	189
	190	=item B<search> - search UPnP devices
	191
	192	@device_list = $ctrlPoint->search();
	193
	194	@device_list = $ctrlPoint->search(
	195	[st => $search_target], # 'upnp:rootdevice'
	196	[mx => $maximum_wait] # 3
	197	);
	198
	199	Search UPnP devices and return the device list. Please see L<Net::UPnP::Device> too.
	200
	201	=back
	202
	203	=head1 SEE ALSO
	204
	205	L<Net::UPnP::Device>
	206
	207	=head1 AUTHOR
	208
	209	Satoshi Konno
	210	skonno@cybergarage.org
	211
	212	CyberGarage
	213	http://www.cybergarage.org
	214
	215	=head1 COPYRIGHT AND LICENSE
	216
	217	Copyright (C) 2005 by Satoshi Konno
	218
	219	It may be used, redistributed, and/or modified under the terms of BSD License.
	220
	221	=cut

+418

-0

lib/Net/UPnP/Device.pm less more

	0	package Net::UPnP::Device;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::Device
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::HTTP;
	10	use Net::UPnP::Service;
	11
	12	use vars qw($_SSDP $_DESCRIPTION $_SERVICELIST);
	13
	14	$_SSDP = 'ssdp';
	15	$_DESCRIPTION = 'description';
	16	$_SERVICELIST = 'serviceList';
	17
	18	#------------------------------
	19	# new
	20	#------------------------------
	21
	22	sub new {
	23	my($class) = shift;
	24	my($this) = {
	25	$Net::UPnP::Device::_SSDP => '',
	26	$Net::UPnP::Device::_DESCRIPTION => '',
	27	@Net::UPnP::Device::_SERVICELIST => (),
	28	};
	29	bless $this, $class;
	30	}
	31
	32	#------------------------------
	33	# ssdp
	34	#------------------------------
	35
	36	sub setssdp() {
	37	my($this) = shift;
	38	$this->{$Net::UPnP::Device::_SSDP} = $_[0];
	39	}
	40
	41	sub getssdp() {
	42	my($this) = shift;
	43	$this->{$Net::UPnP::Device::_SSDP};
	44	}
	45
	46	#------------------------------
	47	# description
	48	#------------------------------
	49
	50	sub setdescription() {
	51	my($this) = shift;
	52	my($description) = $_[0];
	53	$this->{$Net::UPnP::Device::_DESCRIPTION} = $description;
	54	$this->setservicefromdescription($description);
	55	}
	56
	57	sub getdescription() {
	58	my($this) = shift;
	59	my %args = (
	60	name => undef,
	61	@_,
	62	);
	63	if ($args{name}) {
	64	unless ($this->{$Net::UPnP::Device::_DESCRIPTION} =~ m/<$args{name}>(.*)<\/$args{name}>/i) {
	65	return '';
	66	}
	67	return $1;
	68	}
	69	$this->{$Net::UPnP::Device::_DESCRIPTION};
	70	}
	71
	72	#------------------------------
	73	# service
	74	#------------------------------
	75
	76	sub setservicefromdescription() {
	77	my($this) = shift;
	78	my(
	79	$description,
	80	$servicelist_description,
	81	@serviceList,
	82	$service,
	83	);
	84
	85
	86	$description = $_[0];
	87
	88	unless ($description =~ m/<serviceList>(.*)<\/serviceList>/si) {
	89	return;
	90	}
	91
	92	$servicelist_description = $1;
	93
	94	@{$this->{$Net::UPnP::Device::_SERVICELIST}} = ();
	95	while ($servicelist_description =~ m/<service>(.*?)<\/service>/sgi) {
	96	$service = Net::UPnP::Service->new();
	97	$service->setdevicedescription($1);
	98	$service->setdevice($this);
	99	push (@{$this->{$Net::UPnP::Device::_SERVICELIST}}, $service);
	100	}
	101	}
	102
	103	#------------------------------
	104	# serviceList
	105	#------------------------------
	106
	107	sub getservicelist() {
	108	my($this) = shift;
	109	@{$this->{$Net::UPnP::Device::_SERVICELIST}};
	110	}
	111
	112	#------------------------------
	113	# getservicebyname
	114	#------------------------------
	115
	116	sub getservicebyname() {
	117	my($this) = shift;
	118	my ($service_name) = @_;
	119	my (
	120	@serviceList,
	121	$service,
	122	$service_type,
	123	);
	124	@serviceList = $this->getservicelist();
	125	foreach $service (@serviceList) {
	126	$service_type = $service->getservicetype();
	127	if ($service_type eq $service_name) {
	128	return $service;
	129	}
	130	}
	131	return undef;
	132	}
	133
	134	#------------------------------
	135	# getlocation
	136	#------------------------------
	137
	138	sub getlocation() {
	139	my($this) = shift;
	140	unless ($this->{$Net::UPnP::Device::_SSDP} =~ m/LOCATION[ :]+(.*)\r/i) {
	141	return '';
	142	}
	143	return $1;
	144	}
	145
	146	#------------------------------
	147	# getdevicetype
	148	#------------------------------
	149
	150	sub getdevicetype() {
	151	my($this) = shift;
	152	$this->getdescription(name => 'deviceType');
	153	}
	154
	155	#------------------------------
	156	# getfriendlyname
	157	#------------------------------
	158
	159	sub getfriendlyname() {
	160	my($this) = shift;
	161	$this->getdescription(name => 'friendlyName');
	162	}
	163
	164	#------------------------------
	165	# getmanufacturer
	166	#------------------------------
	167
	168	sub getmanufacturer() {
	169	my($this) = shift;
	170	$this->getdescription(name => 'manufacturer');
	171	}
	172
	173	#------------------------------
	174	# getmanufacturerurl
	175	#------------------------------
	176
	177	sub getmanufacturerurl() {
	178	my($this) = shift;
	179	$this->getdescription(name => 'manufacturerURL');
	180	}
	181
	182	#------------------------------
	183	# getmodeldescription
	184	#------------------------------
	185
	186	sub getmodeldescription() {
	187	my($this) = shift;
	188	$this->getdescription(name => 'modelDescription');
	189	}
	190
	191	#------------------------------
	192	# getmodelname
	193	#------------------------------
	194
	195	sub getmodelname() {
	196	my($this) = shift;
	197	$this->getdescription(name => 'modelName');
	198	}
	199
	200	#------------------------------
	201	# getmodelnumber
	202	#------------------------------
	203
	204	sub getmodelnumber() {
	205	my($this) = shift;
	206	$this->getdescription(name => 'modelNumber');
	207	}
	208
	209	#------------------------------
	210	# getmodelurl
	211	#------------------------------
	212
	213	sub getmodelurl() {
	214	my($this) = shift;
	215	$this->getdescription(name => 'modelURL');
	216	}
	217
	218	#------------------------------
	219	# getserialnumber
	220	#------------------------------
	221
	222	sub getserialnumber() {
	223	my($this) = shift;
	224	$this->getdescription(name => 'serialNumber');
	225	}
	226
	227	#------------------------------
	228	# getudn
	229	#------------------------------
	230
	231	sub getudn() {
	232	my($this) = shift;
	233	$this->getdescription(name => 'UDN');
	234	}
	235
	236	#------------------------------
	237	# getupc
	238	#------------------------------
	239
	240	sub getupc() {
	241	my($this) = shift;
	242	$this->getdescription(name => 'UPC');
	243	}
	244
	245	#------------------------------
	246	# geturlbase
	247	#------------------------------
	248
	249	sub geturlbase() {
	250	my($this) = shift;
	251	$this->getdescription(name => 'URLBase');
	252	}
	253
	254	1;
	255
	256	__END__
	257
	258	=head1 NAME
	259
	260	Net::UPnP::Device - Perl extension for UPnP.
	261
	262	=head1 SYNOPSIS
	263
	264	use Net::UPnP::ControlPoint;
	265
	266	my $obj = Net::UPnP::ControlPoint->new();
	267
	268	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	269
	270	$devNum= 0;
	271	foreach $dev (@dev_list) {
	272	$device_type = $dev->getdevicetype();
	273	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	274	next;
	275	}
	276	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	277	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	278	next;
	279	}
	280	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	281	unless (defined(condir_service)) {
	282	next;
	283	}
	284	%action_in_arg = (
	285	'ObjectID' => 0,
	286	'BrowseFlag' => 'BrowseDirectChildren',
	287	'Filter' => '*',
	288	'StartingIndex' => 0,
	289	'RequestedCount' => 0,
	290	'SortCriteria' => '',
	291	);
	292	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	293	unless ($action_res->getstatuscode() == 200) {
	294	next;
	295	}
	296	$actrion_out_arg = $action_res->getargumentlist();
	297	unless ($actrion_out_arg->{'Result'}) {
	298	next;
	299	}
	300	$result = $actrion_out_arg->{'Result'};
	301	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	302	print "\t$1\n";
	303	}
	304	$devNum++;
	305	}
	306
	307	=head1 DESCRIPTION
	308
	309	The package is used a object of UPnP device.
	310
	311	=head1 METHODS
	312
	313	=over 4
	314
	315	=item B<getdescription> - get the description.
	316
	317	$description = $dev->getdescription(
	318	name => $name # undef
	319	);
	320
	321	Get the device description of the SSDP location header.
	322
	323	The function returns the all description when the name parameter is not specified, otherwise return a value the specified name.
	324
	325	=item B<getdevicetype> - get the device type.
	326
	327	$description = $dev->getdevicetype();
	328
	329	Get the device type from the device description.
	330
	331	=item B<getfriendlyname> - get the device type.
	332
	333	$friendlyname = $dev->getfriendlyname();
	334
	335	Get the friendly name from the device description.
	336
	337	=item B<getmanufacturer> - get the manufacturer.
	338
	339	$manufacturer = $dev->getmanufacturer();
	340
	341	Get the manufacturer name from the device description.
	342
	343	=item B<getmanufacturerrul> - get the manufacturer url.
	344
	345	$manufacturer_url = $dev->getmanufacturerrul();
	346
	347	Get the manufacturer url from the device description.
	348
	349	=item B<getmodeldescription> - get the model description.
	350
	351	$model_description = $dev->getmodeldescription();
	352
	353	Get the model description from the device description.
	354
	355	=item B<getmodelname> - get the model name.
	356
	357	$model_name = $dev->getmodelname();
	358
	359	Get the model name from the device description.
	360
	361	=item B<getmodelnumber> - get the model number.
	362
	363	$model_number = $dev->getmodelnumber();
	364
	365	Get the model number from the device description.
	366
	367	=item B<getmodelurl> - get the model url.
	368
	369	$model_url = $dev->getmodelurl();
	370
	371	Get the model url from the device description.
	372
	373	=item B<getserialnumber> - get the serialnumber.
	374
	375	$serialnumber = $dev->getserialnumber();
	376
	377	Get the model description from the device description.
	378
	379	=item B<getudn> - get the device UDN.
	380
	381	$udn = $dev->getudn();
	382
	383	Get the UDN from the device description.
	384
	385	=item B<getupc> - get the device UPC.
	386
	387	$upc = $dev->getupc();
	388
	389	Get the UPC from the device description.
	390
	391	=item B<getservicelist> - get the device type.
	392
	393	@service_list = $dev->getservicelist();
	394
	395	Get the service list in the device. Please see L<Net::UPnP::Service> too.
	396
	397	=back
	398
	399	=head1 SEE ALSO
	400
	401	L<Net::UPnP::Service>
	402
	403	=head1 AUTHOR
	404
	405	Satoshi Konno
	406	skonno@cybergarage.org
	407
	408	CyberGarage
	409	http://www.cybergarage.org
	410
	411	=head1 COPYRIGHT AND LICENSE
	412
	413	Copyright (C) 2005 by Satoshi Konno
	414
	415	It may be used, redistributed, and/or modified under the terms of BSD License.
	416
	417	=cut

+455

-0

lib/Net/UPnP/GW/Gateway.pm less more

	0	package Net::UPnP::GW::Gateway;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::GW::Gateway
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::HTTP;
	10	use Net::UPnP::Device;
	11	use Net::UPnP::Service;
	12
	13	use vars qw($_DEVICE $DEVICE_TYPE $WANIPCONNECTION_SERVICE_TYPE $WANCOMMONINTERFACECONFIG_SERVICE_TYPE);
	14
	15	$_DEVICE = 'device';
	16
	17	$DEVICE_TYPE = 'urn:schemas-upnp-org:device:InternetGatewayDevice:1';
	18	$WANIPCONNECTION_SERVICE_TYPE = 'urn:schemas-upnp-org:service:WANIPConnection:1';
	19	$WANCOMMONINTERFACECONFIG_SERVICE_TYPE = 'urn:schemas-upnp-org:service:WANCommonInterfaceConfig:1';
	20
	21	#------------------------------
	22	# new
	23	#------------------------------
	24
	25	sub new {
	26	my($class) = shift;
	27	my($this) = {
	28	$Net::UPnP::GW::Gateway::_DEVICE => undef,
	29	};
	30	bless $this, $class;
	31	}
	32
	33	#------------------------------
	34	# device
	35	#------------------------------
	36
	37	sub setdevice() {
	38	my($this) = shift;
	39	if (@_) {
	40	$this->{$Net::UPnP::GW::Gateway::_DEVICE} = $_[0];
	41	}
	42	}
	43
	44	sub getdevice() {
	45	my($this) = shift;
	46	$this->{$Net::UPnP::GW::Gateway::_DEVICE};
	47	}
	48
	49	#------------------------------
	50	# getexternalipaddress
	51	#------------------------------
	52
	53	sub getexternalipaddress {
	54	my($this) = shift;
	55
	56	my (
	57	$dev,
	58	$wanipcon_service,
	59	$action_res,
	60	$arg_list,
	61	$ipaddr,
	62	);
	63
	64	$dev = $this->getdevice();
	65	$wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE);
	66	unless ($wanipcon_service) {
	67	return "";
	68	}
	69	$action_res = $wanipcon_service->postaction("GetExternalIPAddress");
	70	if ($action_res->getstatuscode() != 200) {
	71	return "";
	72	}
	73	$arg_list = $action_res->getargumentlist();
	74	$ipaddr = $arg_list->{'NewExternalIPAddress'};
	75
	76	return $ipaddr;
	77	}
	78
	79	#------------------------------
	80	# getportmappingnumberofentries
	81	#------------------------------
	82
	83	sub getportmappingnumberofentries{
	84	my($this) = shift;
	85
	86	my (
	87	$dev,
	88	$wanipcon_service,
	89	$query_res,
	90	);
	91
	92	$dev = $this->getdevice();
	93	$wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE);
	94	unless ($wanipcon_service) {
	95	return 0;
	96	}
	97
	98	$query_res = $wanipcon_service->postquery("PortMappingNumberOfEntries");
	99
	100	if ($query_res->getstatuscode() != 200) {
	101	return 0;
	102	}
	103
	104	return $query_res->getvalue();
	105	}
	106
	107
	108	#------------------------------
	109	# getportmapping
	110	#------------------------------
	111
	112	sub getportmappingentry {
	113	my($this) = shift;
	114
	115	my (
	116	@port_mapping,
	117	$dev,
	118	$port_mapping_num,
	119	$wanipcon_service,
	120	$n,
	121	%req_arg,
	122	$action_res,
	123	$arg_list,
	124	$ipaddr,
	125	);
	126
	127	@port_mapping = ();
	128
	129	$port_mapping_num = $this->getportmappingnumberofentries();
	130	if ($port_mapping_num <= 0) {
	131	return @port_mapping;
	132	}
	133
	134	$dev = $this->getdevice();
	135	$wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE);
	136	unless ($wanipcon_service) {
	137	return @port_mapping ;
	138	}
	139
	140	for ($n=0; $n<$port_mapping_num; $n++) {
	141	#print "[$n]";
	142	%req_arg = (
	143	'NewPortMappingIndex' => $n,
	144	);
	145
	146	$action_res = $wanipcon_service->postaction("GetGenericPortMappingEntry", \%req_arg);
	147	#print "[$n]" .$action_res->getstatuscode() . "\n";
	148	#print %req_arg;
	149	if ($action_res->getstatuscode() != 200) {
	150	push(@port_mapping, undef);
	151	next;
	152	}
	153	$arg_list = $action_res->getargumentlist();
	154	#print $arg_list;
	155	push(@port_mapping, $arg_list);
	156	}
	157
	158	return @port_mapping;
	159	}
	160
	161	#------------------------------
	162	# addportmapping
	163	#------------------------------
	164
	165	sub addportmapping {
	166	my($this) = shift;
	167	my %args = (
	168	NewRemoteHost => '',
	169	NewExternalPort => '',
	170	NewProtocol => '',
	171	NewInternalPort => '',
	172	NewInternalClient => '',
	173	NewEnabled => 1,
	174	NewPortMappingDescription => '',
	175	NewLeaseDuration => 0,
	176	@_,
	177	);
	178
	179	my (
	180	$dev,
	181	$wanipcon_service,
	182	$action_res,
	183	$arg_list,
	184	$ipaddr,
	185	%req_arg,
	186	);
	187
	188	$dev = $this->getdevice();
	189	$wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE);
	190	unless ($wanipcon_service) {
	191	return 0;
	192	}
	193
	194	%req_arg = (
	195	'NewRemoteHost' => $args{NewRemoteHost},
	196	'NewExternalPort' => $args{NewExternalPort},
	197	'NewProtocol' => $args{NewProtocol},
	198	'NewInternalPort' => $args{NewInternalPort},
	199	'NewInternalClient' => $args{NewInternalClient},
	200	'NewEnabled' => $args{NewEnabled},
	201	'NewPortMappingDescription' => $args{NewPortMappingDescription},
	202	'NewLeaseDuration' => $args{NewLeaseDuration},
	203	);
	204
	205	$action_res = $wanipcon_service->postaction("AddPortMapping", \%req_arg);
	206	if ($action_res->getstatuscode() != 200) {
	207	return 0;
	208	}
	209	return 1;
	210	}
	211
	212	#------------------------------
	213	# deleteportmapping
	214	#------------------------------
	215
	216	sub deleteportmapping {
	217	my($this) = shift;
	218	my %args = (
	219	NewRemoteHost => '',
	220	NewExternalPort => '',
	221	NewProtocol => '',
	222	@_,
	223	);
	224
	225	my (
	226	$dev,
	227	$wanipcon_service,
	228	$action_res,
	229	$arg_list,
	230	$ipaddr,
	231	%req_arg,
	232	);
	233
	234	$dev = $this->getdevice();
	235	$wanipcon_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANIPCONNECTION_SERVICE_TYPE);
	236	unless ($wanipcon_service) {
	237	return 0;
	238	}
	239
	240	%req_arg = (
	241	'NewRemoteHost' => $args{NewRemoteHost},
	242	'NewExternalPort' => $args{NewExternalPort},
	243	'NewProtocol' => $args{NewProtocol},
	244	);
	245
	246	$action_res = $wanipcon_service->postaction("DeletePortMapping", \%req_arg);
	247	if ($action_res->getstatuscode() != 200) {
	248	return 0;
	249	}
	250	return 1;
	251	}
	252
	253	#------------------------------
	254	# gettotalbytesrecieved
	255	#------------------------------
	256
	257	sub gettotalbytesrecieved {
	258	my($this) = shift;
	259
	260	my (
	261	$dev,
	262	$wanconif_service,
	263	$action_res,
	264	$arg_list,
	265	$totalBytes,
	266	);
	267
	268	$dev = $this->getdevice();
	269	$wanconif_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANCOMMONINTERFACECONFIG_SERVICE_TYPE);
	270	unless ($wanconif_service) {
	271	return "";
	272	}
	273	$action_res = $wanconif_service->postaction("GetTotalBytesReceived");
	274	if ($action_res->getstatuscode() != 200) {
	275	return "";
	276	}
	277	$arg_list = $action_res->getargumentlist();
	278	$totalBytes = $arg_list->{'NewTotalBytesReceived'};
	279
	280	return $totalBytes;
	281	}
	282
	283	#------------------------------
	284	# gettotalbytessent
	285	#------------------------------
	286
	287	sub gettotalbytessent {
	288	my($this) = shift;
	289
	290	my (
	291	$dev,
	292	$wanconif_service,
	293	$action_res,
	294	$arg_list,
	295	$totalBytes,
	296	);
	297
	298	$dev = $this->getdevice();
	299	$wanconif_service = $dev->getservicebyname($Net::UPnP::GW::Gateway::WANCOMMONINTERFACECONFIG_SERVICE_TYPE);
	300	unless ($wanconif_service) {
	301	return "";
	302	}
	303	$action_res = $wanconif_service->postaction("GetTotalBytesSent");
	304	if ($action_res->getstatuscode() != 200) {
	305	return "";
	306	}
	307	$arg_list = $action_res->getargumentlist();
	308	$totalBytes = $arg_list->{'NewTotalBytesSent'};
	309
	310	return $totalBytes;
	311	}
	312
	313	1;
	314
	315	__END__
	316
	317	=head1 NAME
	318
	319	Net::UPnP::GW::Gateway - Perl extension for UPnP.
	320
	321	=head1 SYNOPSIS
	322
	323	use Net::UPnP::ControlPoint;
	324	use Net::UPnP::GW::Gateway;
	325
	326	my $obj = Net::UPnP::ControlPoint->new();
	327
	328	@dev_list = ();
	329	while (@dev_list <= 0 \|\| $retry_cnt > 5) {
	330	# @dev_list = $obj->search(st =>'urn:schemas-upnp-org:device:InternetGatewayDevice:1', mx => 10);
	331	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	332	$retry_cnt++;
	333	}
	334
	335	$devNum= 0;
	336	foreach $dev (@dev_list) {
	337	my $device_type = $dev->getdevicetype();
	338	if ($device_type ne 'urn:schemas-upnp-org:device:InternetGatewayDevice:1') {
	339	next;
	340	}
	341	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	342	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:WANIPConnection:1')) {
	343	next;
	344	}
	345	my $gwdev = Net::UPnP::GW::Gateway->new();
	346	$gwdev->setdevice($dev);
	347	print "\tExternalIPAddress = " . $gwdev->getexternalipaddress() . "\n";
	348	print "\tPortMappingNumberOfEntries = " . $gwdev->getportmappingnumberofentries() . "\n";
	349	@port_mapping = $gwdev->getportmappingentry();
	350	$port_num = 0;
	351	foreach $port_entry (@port_mapping) {
	352	if ($port_entry) {
	353	$port_map_name = $port_entry->{'NewPortMappingDescription'};
	354	if (length($port_map_name) <= 0) {
	355	$port_map_name = "(No name)";
	356	}
	357	print " [$port_num] : $port_map_name\n";
	358	foreach $name ( keys %{$port_entry} ) {
	359	print " $name = $port_entry->{$name}\n";
	360	}
	361	}
	362	else {
	363	print " [$port_num] : Unknown\n";
	364	}
	365	$port_num++;
	366	}
	367	}
	368
	369	=head1 DESCRIPTION
	370
	371	The package is a extention UPnP/GW.
	372
	373	=head1 METHODS
	374
	375	=over 4
	376
	377	=item B<new> - create new Net::UPnP::GW::Gateway.
	378
	379	$mservier = Net::UPnP::GW::Gateway();
	380
	381	Creates a new object. Read `perldoc perlboot` if you don't understand that.
	382
	383	The new object is not associated with any UPnP devices. Please use setdevice() to set the device.
	384
	385	=item B<setdevice> - set a UPnP devices
	386
	387	$gw->setdevice($dev);
	388
	389	Set a device to the object.
	390
	391	=item B<getexternalipaddress> - External IP address
	392
	393	$gw->getexternalipaddress();
	394
	395	Get the external IP address.
	396
	397	=item B<getportmappingnumberofentries> - PortMappingNumberOfEntries
	398
	399	$gw->getexternalipaddress();
	400
	401	Get the number of the port mapping entries.
	402
	403	=item B<getportmappingentry> - PortMappingEntry
	404
	405	$gw->getexternalipaddress();
	406
	407	Get the port mapping entries.
	408
	409	=item B<addportmapping> - add new port mapping.
	410
	411	$result = gw->addportmapping(
	412	NewRemoteHost # '',
	413	NewExternalPort # '',
	414	NewProtocol # '',
	415	NewInternalPort # '',
	416	NewInternalClient # '',
	417	NewEnabled #1,
	418	NewPortMappingDescription # '',
	419	NewLeaseDuration # 0);
	420
	421	Add a new specified port mapping.
	422
	423	=item B<deleteportmapping> - delete a port mapping.
	424
	425	$result = gw->deleteportmapping(
	426	NewRemoteHost # '',
	427	NewExternalPort # '',
	428	NewProtocol # '');
	429
	430	Delete the specified port mapping.
	431
	432	=item B<gettotalbytesrecieved> - Total recieved bytes.
	433
	434	$gw->gettotalbytesrecieved();
	435
	436	Get the total recieved bytes.
	437
	438	=back
	439
	440	=head1 AUTHOR
	441
	442	Satoshi Konno
	443	skonno@cybergarage.org
	444
	445	CyberGarage
	446	http://www.cybergarage.org
	447
	448	=head1 COPYRIGHT AND LICENSE
	449
	450	Copyright (C) 2005 by Satoshi Konno
	451
	452	It may be used, redistributed, and/or modified under the terms of BSD License.
	453
	454	=cut

+206

-0

lib/Net/UPnP/HTTP.pm less more

	0	package Net::UPnP::HTTP;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::HTTP
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Socket;
	10
	11	use Net::UPnP;
	12	use Net::UPnP::HTTPResponse;
	13
	14	use vars qw($STATUS_CODE $STATUS $HEADER $CONTENT $POST $GET);
	15
	16	$POST = 'POST';
	17	$GET = 'GET';
	18
	19	$STATUS_CODE = 'status_code';
	20	$STATUS = 'status';
	21	$HEADER = 'header';
	22	$CONTENT = 'content';
	23
	24	#------------------------------
	25	# new
	26	#------------------------------
	27
	28	sub new {
	29	my($class) = shift;
	30	my($this) = {};
	31	bless $this, $class;
	32	}
	33
	34	#------------------------------
	35	# post
	36	#------------------------------
	37
	38	sub post {
	39	my($this) = shift;
	40	if (@_ < 6) {
	41	return "";
	42	}
	43	my ($post_addr, $post_port, $method, $path, $add_header, $req_content) = @_;
	44	my (
	45	$post_sockaddr,
	46	$req_content_len,
	47	$add_header_name,
	48	$add_header_value,
	49	$req_header,
	50	$res_status,
	51	$res_header_cnt,
	52	$res_header,
	53	$res_content_len,
	54	$res_content,
	55	$res,
	56	);
	57
	58	$req_content_len = length($req_content);
	59
	60	$req_header = <<"REQUEST_HEADER";
	61	$method $path HTTP/1.0
	62	Host: $post_addr:$post_port
	63	Content-Length: $req_content_len
	64	REQUEST_HEADER
	65
	66	#print "header = " . %{$add_header} . "\n";
	67	#%add_header = %{$add_header_ref};
	68	if (ref $add_header) {
	69	while ( ($add_header_name, $add_header_value) = each %{$add_header}) {
	70	$req_header .= "$add_header_name: $add_header_value\n";
	71	}
	72	}
	73
	74	$req_header .= "\n";
	75	$req_header =~ s/\r//g;
	76	$req_header =~ s/\n/\r\n/g;
	77
	78	$post_sockaddr = sockaddr_in($post_port, inet_aton($post_addr));
	79	socket(HTTP_SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
	80	connect(HTTP_SOCK, $post_sockaddr);
	81	select(HTTP_SOCK); $\|=1; select(STDOUT);
	82
	83	if ($Net::UPnP::DEBUG) {
	84	print $req_header;
	85	print $req_content;
	86	}
	87
	88	print HTTP_SOCK $req_header;
	89	print HTTP_SOCK $req_content;
	90
	91	$res_status = "";
	92	$res_header = "";
	93	$res_header_cnt = 0;
	94	while(<HTTP_SOCK>) {
	95	if (m/^\r\n$/) {
	96	last;
	97	}
	98	$res_header_cnt++;
	99	if ($res_header_cnt == 1) {
	100	$res_status .= $_;
	101	next;
	102	}
	103	$res_header .= $_;
	104	}
	105
	106	$res_content_len = 0;
	107	if($res_header =~ m/^Content-Length[: ]*(\d+)/i ) {
	108	$res_content_len = $1
	109	}
	110
	111	$res_content = "";
	112	if ($res_content_len) {
	113	read(HTTP_SOCK, $res_content, $res_content_len);
	114	}
	115	else {
	116	while(<HTTP_SOCK>) {
	117	$res_content .= $_;
	118	}
	119	}
	120
	121	close(HTTP_SOCK);
	122
	123	$res = Net::UPnP::HTTPResponse->new();
	124	$res->setstatus($res_status);
	125	$res->setheader($res_header);
	126	$res->setcontent($res_content);
	127
	128	if ($Net::UPnP::DEBUG) {
	129	print $res_status;
	130	print $res_header;
	131	print $res_content;
	132	}
	133
	134	return $res;
	135	}
	136
	137	#------------------------------
	138	# postsoap
	139	#------------------------------
	140
	141	sub postsoap {
	142	my($this) = shift;
	143	my ($post_addr, $post_port, $path, $action_name, $action_content) = @_;
	144	my (
	145	%soap_header,
	146	$name,
	147	$value
	148	);
	149
	150	%soap_header = (
	151	'Content-Type' => "text/xml; charset=\"utf-8\"",
	152	'SOAPACTION' => $action_name,
	153	);
	154
	155	$this->post($post_addr, $post_port, $Net::UPnP::HTTP::POST, $path, \%soap_header, $action_content);
	156	}
	157
	158	#------------------------------
	159	# postsoap
	160	#------------------------------
	161
	162	sub xmldecode {
	163	my (
	164	$str
	165	);
	166	if (ref $_[0]) {
	167	$str = $_[1];
	168	}
	169	else {
	170	$str = $_[0];
	171	}
	172	$str =~ s/\>/>/g;
	173	$str =~ s/\</</g;
	174	$str =~ s/\"/\"/g;
	175	$str =~ s/\&/\&/g;
	176	$str;
	177	}
	178
	179	1;
	180
	181	__END__
	182
	183	=head1 NAME
	184
	185	Net::UPnP::HTTP - Perl extension for UPnP.
	186
	187	=head1 DESCRIPTION
	188
	189	The package is a inside module.
	190
	191	=head1 AUTHOR
	192
	193	Satoshi Konno
	194	skonno@cybergarage.org
	195
	196	CyberGarage
	197	http://www.cybergarage.org
	198
	199	=head1 COPYRIGHT AND LICENSE
	200
	201	Copyright (C) 2005 by Satoshi Konno
	202
	203	It may be used, redistributed, and/or modified under the terms of BSD License.
	204
	205	=cut

+111

-0

lib/Net/UPnP/HTTPResponse.pm less more

	0	package Net::UPnP::HTTPResponse;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::HTTPResponse
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use vars qw($_STATUS $_HEADER $_CONTENT);
	10
	11	$_STATUS = 'status';
	12	$_HEADER = 'header';
	13	$_CONTENT = 'content';
	14
	15	#------------------------------
	16	# new
	17	#------------------------------
	18
	19	sub new {
	20	my($class) = shift;
	21	my($this) = {
	22	$Net::UPnP::HTTPResponse::_STATUS => '',
	23	$Net::UPnP::HTTPResponse::_HEADER => '',
	24	$Net::UPnP::HTTPResponse::_CONTENT => '',
	25	};
	26	bless $this, $class;
	27	}
	28
	29	#------------------------------
	30	# status
	31	#------------------------------
	32
	33	sub setstatus() {
	34	my($this) = shift;
	35	$this->{$Net::UPnP::HTTPResponse::_STATUS} = $_[0];
	36	}
	37
	38	sub getstatus() {
	39	my($this) = shift;
	40	$this->{$Net::UPnP::HTTPResponse::_STATUS};
	41	}
	42
	43	sub getstatuscode() {
	44	my($this) = shift;
	45	my($status) = $this->{$Net::UPnP::HTTPResponse::_STATUS};
	46	if (length($status) <= 0) {
	47	return 0;
	48	}
	49	if($status =~ m/^HTTP\/\d.\d\s+(\d+)\s+.*/i ) {
	50	return $1;
	51	}
	52	return 0;
	53	}
	54
	55	#------------------------------
	56	# header
	57	#------------------------------
	58
	59	sub setheader() {
	60	my($this) = shift;
	61	$this->{$Net::UPnP::HTTPResponse::_HEADER} = $_[0];
	62	}
	63
	64	sub getheader() {
	65	my($this) = shift;
	66	$this->{$Net::UPnP::HTTPResponse::_HEADER};
	67	}
	68
	69	#------------------------------
	70	# content
	71	#------------------------------
	72
	73	sub setcontent() {
	74	my($this) = shift;
	75	$this->{$Net::UPnP::HTTPResponse::_CONTENT} = $_[0];
	76	}
	77
	78	sub getcontent() {
	79	my($this) = shift;
	80	$this->{$Net::UPnP::HTTPResponse::_CONTENT};
	81	}
	82
	83	1;
	84
	85
	86	__END__
	87
	88	=head1 NAME
	89
	90	Net::UPnP::HTTPResponse - Perl extension for UPnP.
	91
	92	=head1 DESCRIPTION
	93
	94	The package is a inside module.
	95
	96	=head1 AUTHOR
	97
	98	Satoshi Konno
	99	skonno@cybergarage.org
	100
	101	CyberGarage
	102	http://www.cybergarage.org
	103
	104	=head1 COPYRIGHT AND LICENSE
	105
	106	Copyright (C) 2005 by Satoshi Konno
	107
	108	It may be used, redistributed, and/or modified under the terms of BSD License.
	109
	110	=cut

+198

-0

lib/Net/UPnP/QueryResponse.pm less more

	0	package Net::UPnP::QueryResponse;
	1
	2	#-----------------------------------------------------------------
	3	# Net::UPnP::QueryResponse
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP::HTTP;
	10	use Net::UPnP::HTTPResponse;
	11
	12	use vars qw($_HTTP_RESPONSE);
	13
	14	$_HTTP_RESPONSE = 'httpres';
	15
	16	#------------------------------
	17	# new
	18	#------------------------------
	19
	20	sub new {
	21	my($class) = shift;
	22	my($this) = {
	23	$Net::UPnP::QueryResponse::_HTTP_RESPONSE => undef,
	24	};
	25	bless $this, $class;
	26	}
	27
	28	#------------------------------
	29	# header
	30	#------------------------------
	31
	32	sub sethttpresponse() {
	33	my($this) = shift;
	34	$this->{$Net::UPnP::QueryResponse::_HTTP_RESPONSE} = $_[0];
	35	}
	36
	37	sub gethttpresponse() {
	38	my($this) = shift;
	39	$this->{$Net::UPnP::QueryResponse::_HTTP_RESPONSE};
	40	}
	41
	42	#------------------------------
	43	# status
	44	#------------------------------
	45
	46	sub getstatus() {
	47	my($this) = shift;
	48	my($http_res) = $this->gethttpresponse();
	49	$http_res->getstatus();
	50	}
	51
	52	sub getstatuscode() {
	53	my($this) = shift;
	54	my($http_res) = $this->gethttpresponse();
	55	$http_res->getstatuscode();
	56	}
	57
	58	#------------------------------
	59	# header
	60	#------------------------------
	61
	62	sub getheader() {
	63	my($this) = shift;
	64	my($http_res) = $this->gethttpresponse();
	65	$http_res->getheader();
	66	}
	67
	68	#------------------------------
	69	# content
	70	#------------------------------
	71
	72	sub getcontent() {
	73	my($this) = shift;
	74	my($http_res) = $this->gethttpresponse();
	75	$http_res->getcontent();
	76	}
	77
	78	#------------------------------
	79	# content
	80	#------------------------------
	81
	82	sub getvalue() {
	83	my($this) = shift;
	84	my(
	85	$http_res,
	86	$res_statcode,
	87	$res_content,
	88	$value,
	89	);
	90
	91	$http_res = $this->gethttpresponse();
	92
	93	$res_statcode = $http_res->getstatuscode();
	94	if ($res_statcode != 200) {
	95	return "";
	96	}
	97
	98	$value = "";
	99
	100	$res_content = $http_res->getcontent();
	101	if ($res_content =~ m/<return>(.*?)<\/return>/si) {
	102	$value = $1;
	103	}
	104
	105	return $value;
	106	}
	107
	108	1;
	109
	110	__END__
	111
	112	=head1 NAME
	113
	114	Net::UPnP::QueryResponse - Perl extension for UPnP.
	115
	116	=head1 SYNOPSIS
	117
	118	use Net::UPnP::ControlPoint;
	119
	120	my $obj = Net::UPnP::ControlPoint->new();
	121
	122	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	123
	124	$devNum= 0;
	125	foreach $dev (@dev_list) {
	126	$device_type = $dev->getdevicetype();
	127	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	128	next;
	129	}
	130	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	131	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	132	next;
	133	}
	134	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	135	unless (defined(condir_service)) {
	136	next;
	137	}
	138	%action_in_arg = (
	139	'ObjectID' => 0,
	140	'BrowseFlag' => 'BrowseDirectChildren',
	141	'Filter' => '*',
	142	'StartingIndex' => 0,
	143	'RequestedCount' => 0,
	144	'SortCriteria' => '',
	145	);
	146	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	147	unless ($action_res->getstatuscode() == 200) {
	148	next;
	149	}
	150	$actrion_out_arg = $action_res->getargumentlist();
	151	unless ($actrion_out_arg->{'Result'}) {
	152	next;
	153	}
	154	$result = $actrion_out_arg->{'Result'};
	155	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	156	print "\t$1\n";
	157	}
	158	$devNum++;
	159	}
	160
	161	=head1 DESCRIPTION
	162
	163	The package is used a object of the action response.
	164
	165	=head1 METHODS
	166
	167	=over 4
	168
	169	=item B<getstatuscode> - get the status code.
	170
	171	$status_code = $queryres->getstatuscode();
	172
	173	Get the status code of the SOAP response.
	174
	175	=item B<getvalue> - get the return value.
	176
	177	$value = $queryres->getvalue();
	178
	179	Get the value of the SOAP response.
	180
	181	=back
	182
	183	=head1 AUTHOR
	184
	185	Satoshi Konno
	186	skonno@cybergarage.org
	187
	188	CyberGarage
	189	http://www.cybergarage.org
	190
	191	=head1 COPYRIGHT AND LICENSE
	192
	193	Copyright (C) 2005 by Satoshi Konno
	194
	195	It may be used, redistributed, and/or modified under the terms of BSD License.
	196
	197	=cut

+448

-0

lib/Net/UPnP/Service.pm less more

	0	package Net::UPnP::Service;
	1
	2	#-----------------------------------------------------------------
	3	# Net::Net::UPnP::Service
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use Net::UPnP;
	10	use Net::UPnP::ActionResponse;
	11	use Net::UPnP::QueryResponse;
	12
	13	use vars qw($_DEVICE $_DEVICE_DESCRIPTION $SERVICETYPE $SERVICEID $SCPDURL $CONTROLURL $EVENTSUBURL);
	14
	15	$_DEVICE = 'device';
	16	$_DEVICE_DESCRIPTION = 'device_description';
	17
	18	$SERVICETYPE = 'serviceType';
	19	$SERVICEID = 'serviceId';
	20	$SCPDURL = 'SCPDURL';
	21	$CONTROLURL = 'controlURL';
	22	$EVENTSUBURL = 'eventSubURL';
	23
	24	#------------------------------
	25	# new
	26	#------------------------------
	27
	28	sub new {
	29	my($class) = shift;
	30	my($this) = {
	31	$Net::UPnP::Service::_DEVICE => undef,
	32	$Net::UPnP::Service::_DEVICE_DESCRIPTION => '',
	33	};
	34	bless $this, $class;
	35	}
	36
	37	#------------------------------
	38	# device
	39	#------------------------------
	40
	41	sub setdevice() {
	42	my($this) = shift;
	43	if (@_) {
	44	$this->{$Net::UPnP::Service::_DEVICE} = $_[0];
	45	}
	46	}
	47
	48	sub getdevice() {
	49	my($this) = shift;
	50	$this->{$Net::UPnP::Service::_DEVICE};
	51	}
	52
	53	#------------------------------
	54	# device description
	55	#------------------------------
	56
	57	sub setdevicedescription() {
	58	my($this) = shift;
	59	$this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION} = $_[0];
	60	}
	61
	62	sub getdevicedescription() {
	63	my($this) = shift;
	64	my %args = (
	65	name => undef,
	66	@_,
	67	);
	68	if ($args{name}) {
	69	unless ($this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION} =~ m/<$args{name}>(.*)<\/$args{name}>/i) {
	70	return '';
	71	}
	72	return $1;
	73	}
	74	$this->{$Net::UPnP::Service::_DEVICE_DESCRIPTION};
	75	}
	76
	77	#------------------------------
	78	# getservicetype
	79	#------------------------------
	80
	81	sub getservicetype() {
	82	my($this) = shift;
	83	$this->getdevicedescription(name => $Net::UPnP::Service::SERVICETYPE);
	84	}
	85
	86	#------------------------------
	87	# getserviceid
	88	#------------------------------
	89
	90	sub getserviceid() {
	91	my($this) = shift;
	92	$this->getdevicedescription(name => $Net::UPnP::Service::SERVICEID);
	93	}
	94
	95	#------------------------------
	96	# getscpdurl
	97	#------------------------------
	98
	99	sub getscpdurl() {
	100	my($this) = shift;
	101	$this->getdevicedescription(name => $Net::UPnP::Service::SCPDURL);
	102	}
	103
	104	#------------------------------
	105	# getcontrolurl
	106	#------------------------------
	107
	108	sub getcontrolurl() {
	109	my($this) = shift;
	110	$this->getdevicedescription(name => $Net::UPnP::Service::CONTROLURL);
	111	}
	112
	113	#------------------------------
	114	# geteventsuburl
	115	#------------------------------
	116
	117	sub geteventsuburl() {
	118	my($this) = shift;
	119	$this->getdevicedescription(name => $Net::UPnP::Service::EVENTSUBURL);
	120	}
	121
	122	#------------------------------
	123	# getposturl
	124	#------------------------------
	125
	126	sub getposturl() {
	127	my($this) = shift;
	128	my ($ctrl_url) = @_;
	129	my (
	130	$dev,
	131	$location_url,
	132	$url_base,
	133	);
	134
	135	$dev = $this->getdevice();
	136
	137	$location_url = $dev->getlocation();
	138	$url_base = $dev->geturlbase();
	139	$ctrl_url = $this->getcontrolurl();
	140
	141	#print "$location_url\n";
	142	#print "$url_base\n";
	143	#print "$ctrl_url\n";
	144
	145	unless ($ctrl_url =~ m/http:\/\/(.*)/i) {
	146	if (0 < length($url_base)) {
	147	# Thanks for Thus0 (2005/01/12)
	148	if (rindex($url_base, '/') == (length($url_base)-1) && index($ctrl_url, '/') == 0) {
	149	$ctrl_url = $url_base . substr($ctrl_url, 1);
	150	} else {
	151	$ctrl_url = $url_base . $ctrl_url;
	152	}
	153	}
	154	else {
	155	if ($location_url =~ m/http:\/\/([0-9a-z.]+)[:]([0-9])\/(.*)/i) {
	156	if (defined($3) && 0 < length($3)) {
	157	$ctrl_url = "http:\/\/" . $1 . ":" . $2 . $ctrl_url;
	158	} else {
	159	$ctrl_url = "http:\/\/" . $1 . ":" . $2 . "\/" . $ctrl_url;
	160	}
	161	} else {
	162	$ctrl_url = $location_url . $ctrl_url;
	163	}
	164	}
	165	}
	166
	167	return $ctrl_url;
	168	}
	169
	170	#------------------------------
	171	# postaction
	172	#------------------------------
	173
	174	sub postaction() {
	175	my($this) = shift;
	176	my ($action_name, $action_arg) = @_;
	177	my (
	178	$dev,
	179	$ctrl_url,
	180	$service_type,
	181	$soap_action,
	182	$soap_content,
	183	$arg_name,
	184	$arg_value,
	185	$post_addr,
	186	$post_port,
	187	$post_path,
	188	$http_req,
	189	$post_res,
	190	$action_res,
	191	$key,
	192	);
	193
	194	$action_res = Net::UPnP::ActionResponse->new();
	195
	196	$dev = $this->getdevice();
	197	$ctrl_url = $this->getcontrolurl();
	198	$ctrl_url = $this->getposturl($ctrl_url);
	199
	200	unless ($ctrl_url =~ m/http:\/\/([0-9a-z.]+)[:]([0-9])\/(.*)/i) {
	201	#print "Invalid URL : $ctrl_url\n";
	202	$post_res = Net::UPnP::HTTPResponse->new();
	203	$action_res->sethttpresponse($post_res);
	204	return $action_res;
	205	}
	206	$post_addr = $1;
	207	$post_port = $2;
	208	if (index($3, '/') == 0) {
	209	$post_path = $3;
	210	}
	211	else {
	212	$post_path = "\/" . $3;
	213	}
	214
	215	$service_type = $this->getservicetype();
	216	$soap_action = "\"" . $service_type . "#" . $action_name . "\"";
	217
	218
	219	$soap_content = <<"SOAP_CONTENT";
	220	<?xml version=\"1.0\" encoding=\"utf-8\"?>
	221	<s:Envelope xmlns:s=\"http:\/\/schemas.xmlsoap.org\/soap\/envelope\/\" s:encodingStyle=\"http:\/\/schemas.xmlsoap.org\/soap\/encoding/\">
	222	\t<s:Body>
	223	\t\t<u:$action_name xmlns:u=\"$service_type\">
	224	SOAP_CONTENT
	225
	226	if (ref $action_arg) {
	227	while (($arg_name, $arg_value) = each (%{$action_arg} ) ) {
	228	if (length($arg_value) <= 0) {
	229	$soap_content .= "\t\t\t<$arg_name \/>\n";
	230	next;
	231	}
	232	$soap_content .= "\t\t\t<$arg_name>$arg_value<\/$arg_name>\n";
	233	}
	234	}
	235
	236	$soap_content .= <<"SOAP_CONTENT";
	237	\t\t</u:$action_name>
	238	\t</s:Body>
	239	</s:Envelope>
	240	SOAP_CONTENT
	241
	242	$http_req = Net::UPnP::HTTP->new();
	243	$post_res = $http_req->postsoap($post_addr, $post_port, $post_path, $soap_action, $soap_content);
	244
	245	$action_res->sethttpresponse($post_res);
	246
	247	return $action_res;
	248	}
	249
	250	#------------------------------
	251	# postcontrol
	252	#------------------------------
	253
	254	sub postcontrol() {
	255	my($this) = shift;
	256	my ($action_name, $action_arg) = @_;
	257	return $this->postaction($action_name, $action_arg);
	258	}
	259
	260	#------------------------------
	261	# postquery
	262	#------------------------------
	263
	264	sub postquery() {
	265	my($this) = shift;
	266	my ($var_name) = @_;
	267	my (
	268	$dev,
	269	$ctrl_url,
	270	$service_type,
	271	$soap_action,
	272	$soap_content,
	273	$post_addr,
	274	$post_port,
	275	$post_path,
	276	$http_req,
	277	$post_res,
	278	$query_res,
	279	);
	280
	281	$query_res = Net::UPnP::QueryResponse->new();
	282
	283	$dev = $this->getdevice();
	284	$ctrl_url = $this->getcontrolurl();
	285	$ctrl_url = $this->getposturl($ctrl_url);
	286
	287	unless ($ctrl_url =~ m/http:\/\/([0-9a-z.]+)[:]([0-9])\/(.*)/i) {
	288	#print "Invalid URL : $ctrl_url\n";
	289	$post_res = Net::UPnP::HTTPResponse->new();
	290	$query_res->sethttpresponse($post_res);
	291	return $query_res;
	292	}
	293	$post_addr = $1;
	294	$post_port = $2;
	295	if (index($3, '/') == 0) {
	296	$post_path = $3;
	297	}
	298	else {
	299	$post_path = "\/" . $3;
	300	}
	301
	302	$service_type = $this->getservicetype();
	303	$soap_action = "\"urn:schemas-upnp-org:control-1-0#QueryStateVariable\"";
	304
	305	$soap_content = <<"SOAP_CONTENT";
	306	<?xml version=\"1.0\" encoding=\"utf-8\"?>
	307	<s:Envelope xmlns:s=\"http:\/\/schemas.xmlsoap.org\/soap\/envelope\/\" s:encodingStyle=\"http:\/\/schemas.xmlsoap.org\/soap\/encoding/\">
	308	\t<s:Body>
	309	\t\t<u:QueryStateVariable xmlns:u=\"urn:schemas-upnp-org:control-1-0\">
	310	\t\t\t<u:varName>$var_name</u:varName>
	311	\t\t</u:QueryStateVariable>
	312	\t</s:Body>
	313	</s:Envelope>
	314	SOAP_CONTENT
	315
	316	$http_req = Net::UPnP::HTTP->new();
	317	$post_res = $http_req->postsoap($post_addr, $post_port, $post_path, $soap_action, $soap_content);
	318
	319	$query_res->sethttpresponse($post_res);
	320
	321	return $query_res;
	322	}
	323
	324	1;
	325
	326	__END__
	327
	328	=head1 NAME
	329
	330	Net::UPnP::Service - Perl extension for UPnP.
	331
	332	=head1 SYNOPSIS
	333
	334	use Net::UPnP::ControlPoint;
	335
	336	my $obj = Net::UPnP::ControlPoint->new();
	337
	338	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	339
	340	$devNum= 0;
	341	foreach $dev (@dev_list) {
	342	$device_type = $dev->getdevicetype();
	343	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	344	next;
	345	}
	346	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	347	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	348	next;
	349	}
	350	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	351	unless (defined(condir_service)) {
	352	next;
	353	}
	354	%action_in_arg = (
	355	'ObjectID' => 0,
	356	'BrowseFlag' => 'BrowseDirectChildren',
	357	'Filter' => '*',
	358	'StartingIndex' => 0,
	359	'RequestedCount' => 0,
	360	'SortCriteria' => '',
	361	);
	362	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	363	unless ($action_res->getstatuscode() == 200) {
	364	next;
	365	}
	366	$actrion_out_arg = $action_res->getargumentlist();
	367	unless ($actrion_out_arg->{'Result'}) {
	368	next;
	369	}
	370	$result = $actrion_out_arg->{'Result'};
	371	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	372	print "\t$1\n";
	373	}
	374	$devNum++;
	375	}
	376
	377	=head1 DESCRIPTION
	378
	379	The package is used a object of UPnP service.
	380
	381	=head1 METHODS
	382
	383	=over 4
	384
	385	=item B<getdevice> - get the device.
	386
	387	$description = $service->getdevice();
	388
	389	Get the parent device of the service.
	390
	391	=item B<getdevicedescription> - get the service description of the device description.
	392
	393	$description = $service->getdevicedescription(
	394	name => $name # undef
	395	);
	396
	397	Get the service description of the device description.
	398
	399	The function returns the all description when the name parameter is not specified, otherwise return a value the specified name.
	400
	401	=item B<getservicetype> - get the service type.
	402
	403	$service_type = $service->getservicetype();
	404
	405	Get the service type.
	406
	407	=item B<getserviceid> - get the service id.
	408
	409	$service_id = $service->getserviceid();
	410
	411	Get the service id.
	412
	413	=item B<postaction> - post a action control.
	414
	415	$action_res = $service->postcontrol($action_name, \%action_arg);
	416
	417	Post a action control to the device, and return L<Net::UPnP::ActionResponse>.
	418
	419	The method was renamed from postcontrol(), but the old name is deprecated.
	420
	421	=item B<postquery> - post a query control.
	422
	423	$query_res = $service->postcontrol($var_name);
	424
	425	Post a query control to the device, and return L<Net::UPnP::QueryResponse>.
	426
	427	=back
	428
	429	=head1 SEE ALSO
	430
	431	L<Net::UPnP::ActionResponse>
	432
	433	=head1 AUTHOR
	434
	435	Satoshi Konno
	436	skonno@cybergarage.org
	437
	438	CyberGarage
	439	http://www.cybergarage.org
	440
	441	=head1 COPYRIGHT AND LICENSE
	442
	443	Copyright (C) 2005 by Satoshi Konno
	444
	445	It may be used, redistributed, and/or modified under the terms of BSD License.
	446
	447	=cut

+104

-0

lib/Net/UPnP.pm less more

	0	package Net::UPnP;
	1
	2	#-----------------------------------------------------------------
	3	# UPnP
	4	#-----------------------------------------------------------------
	5
	6	use strict;
	7	use warnings;
	8
	9	use vars qw($VERSION $DEBUG $SSDP_ADDR $SSDP_PORT);
	10
	11	$VERSION = '1.2.4';
	12	$DEBUG = 0;
	13
	14	$SSDP_ADDR = '239.255.255.250';
	15	$SSDP_PORT = 1900;
	16
	17	1;
	18
	19	__END__
	20
	21	=head1 NAME
	22
	23	Net::UPnP - Perl extension for UPnP
	24
	25	=head1 SYNOPSIS
	26
	27	use Net::UPnP::ControlPoint;
	28
	29	my $obj = Net::UPnP::ControlPoint->new();
	30
	31	@dev_list = $obj->search(st =>'upnp:rootdevice', mx => 3);
	32
	33	$devNum= 0;
	34	foreach $dev (@dev_list) {
	35	$device_type = $dev->getdevicetype();
	36	if ($device_type ne 'urn:schemas-upnp-org:device:MediaServer:1') {
	37	next;
	38	}
	39	print "[$devNum] : " . $dev->getfriendlyname() . "\n";
	40	unless ($dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1')) {
	41	next;
	42	}
	43	$condir_service = $dev->getservicebyname('urn:schemas-upnp-org:service:ContentDirectory:1');
	44	unless (defined(condir_service)) {
	45	next;
	46	}
	47	%action_in_arg = (
	48	'ObjectID' => 0,
	49	'BrowseFlag' => 'BrowseDirectChildren',
	50	'Filter' => '*',
	51	'StartingIndex' => 0,
	52	'RequestedCount' => 0,
	53	'SortCriteria' => '',
	54	);
	55	$action_res = $condir_service->postcontrol('Browse', \%action_in_arg);
	56	unless ($action_res->getstatuscode() == 200) {
	57	next;
	58	}
	59	$actrion_out_arg = $action_res->getargumentlist();
	60	unless ($actrion_out_arg->{'Result'}) {
	61	next;
	62	}
	63	$result = $actrion_out_arg->{'Result'};
	64	while ($result =~ m/<dc:title>(.*?)<\/dc:title>/sgi) {
	65	print "\t$1\n";
	66	}
	67	$devNum++;
	68	}
	69
	70	=head1 DESCRIPTION
	71
	72	This package provides some functions to control UPnP devices.
	73
	74	Currently, the package provides only functions for the control point.
	75	To control UPnP devices, see L<Net::UPnP::ControlPoint>.
	76
	77	As a sample of the control point, the package provides
	78	L<Net::UPnP::AV::MediaServer> to control the devices such as
	79	DLNA media servers. As the example, please dms2vodcast.pl
	80	that converts from the MPEG2 movies to the MPEG4 one and
	81	outputs the RSS file for Vodcasting.
	82
	83	=head1 SEE ALSO
	84
	85	L<Net::UPnP::ControlPoint>
	86
	87	L<Net::UPnP::AV::MediaServer>
	88
	89	=head1 AUTHOR
	90
	91	Satoshi Konno
	92	skonno@cybergarage.org
	93
	94	CyberGarage
	95	http://www.cybergarage.org
	96
	97	=head1 COPYRIGHT AND LICENSE
	98
	99	Copyright (C) 2005 by Satoshi Konno
	100
	101	It may be used, redistributed, and/or modified under the terms of BSD License.
	102
	103	=cut

+15

-0

t/UPnP.t less more

	0	# Before `make install' is performed this script should be runnable with
	1	# `make test'. After `make install' it should work as `perl UPnP.t'
	2
	3	#########################
	4
	5	# change 'tests => 1' to 'tests => last_test_to_print';
	6
	7	use Test::More tests => 1;
	8	BEGIN { use_ok('Net::UPnP') };
	9
	10	#########################
	11
	12	# Insert your test code below, the Test::More module is use()ed here so read
	13	# its man page ( perldoc Test::More ) for help writing this test script.
	14