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