File Coverage

blib/lib/Power/Outlet/Common/IP/HTTP/UPnP.pm
Criterion Covered Total %
statement 18 42 42.8
branch 0 16 0.0
condition n/a
subroutine 6 9 66.6
pod 2 2 100.0
total 26 69 37.6


line stmt bran cond sub pod time code
1             package Power::Outlet::Common::IP::HTTP::UPnP;
2 2     2   1021 use strict;
  2         5  
  2         56  
3 2     2   11 use warnings;
  2         4  
  2         51  
4 2     2   11 use base qw{Power::Outlet::Common::IP::HTTP};
  2         3  
  2         614  
5 2     2   1008 use XML::LibXML::LazyBuilder qw{DOM E};
  2         91579  
  2         157  
6 2     2   943 use Net::UPnP::HTTP;
  2         11230  
  2         80  
7 2     2   922 use Net::UPnP::ActionResponse;
  2         1445  
  2         840  
8              
9             our $VERSION = '0.50';
10              
11             =head1 NAME
12              
13             Power::Outlet::Common::IP::HTTP::UPnP - Power::Outlet base class for UPnP power outlet
14              
15             =head1 SYNOPSIS
16              
17             use base qw{Power::Outlet::Common::IP::HTTP::UPnP};
18              
19             =head1 DESCRIPTION
20              
21             Power::Outlet::Common::IP::HTTP::UPnP is a package for controlling and querying an UPnP-based network attached power outlet.
22              
23             =head1 USAGE
24              
25             use base qw{Power::Outlet::Common::IP::HTTP::UPnP};
26              
27             =head1 PROPERTIES
28              
29             =head2 upnp_service_type
30              
31             =cut
32              
33             sub upnp_service_type {
34 0     0 1   my $self=shift;
35 0 0         $self->{"upnp_service_type"}=shift if @_;
36 0 0         $self->{"upnp_service_type"}=$self->_upnp_service_type_default unless defined $self->{"upnp_service_type"};
37 0           return $self->{"upnp_service_type"};
38             }
39              
40 0     0     sub _upnp_service_type_default {"urn:Belkin:service:basicevent:1"}; #WeMo default
41              
42             =head1 METHODS
43              
44             =head2 upnp_request
45              
46             Returns a L object
47              
48             my $res=$obj->upnp_request($request_type, $event_name, $value);
49             my $res=$obj->upnp_request("Get", "BinaryState");
50             my $res=$obj->upnp_request("Set", "BinaryState", 0);
51             my $res=$obj->upnp_request("Set", "BinaryState", 1);
52              
53             =cut
54              
55             sub upnp_request {
56 0     0 1   my $self = shift;
57 0 0         my $request_type = shift or die; #e.g. Get|Set
58 0 0         my $event_name = shift or die; #e.g. BinaryState
59 0           my $action_name = "$request_type$event_name"; #e.g. SetBinaryState
60              
61 0           my $soap_action = sprintf(qq{"%s#%s"}, $self->upnp_service_type, $action_name);
62              
63 0           my $xmlns={"xmlns:s"=>"http://schemas.xmlsoap.org/soap/envelope/", "s:encodingStyle"=>"http://schemas.xmlsoap.org/soap/encoding/"};
64              
65 0           my $soap_content_obj;
66              
67 0 0         if ($request_type eq "Set") {
    0          
68 0 0         die("Error: Value required for Set request type") unless @_;
69 0           my $value = shift;
70 0           $soap_content_obj = DOM(
71             E("s:Envelope"=>$xmlns,
72             E("s:Body"=>{},
73             E("u:$action_name"=>{"xmlns:u" => $self->upnp_service_type},
74             E($event_name=>{}, $value)))));
75             } elsif ($request_type eq "Get") {
76 0           $soap_content_obj = DOM(
77             E("s:Envelope"=>$xmlns,
78             E("s:Body"=>{},
79             E("u:$action_name"=>{"xmlns:u" => $self->upnp_service_type}))));
80             } else {
81 0           die(qq{Error: Unknown request type "$request_type". Expected either "Get" or "Set".});
82             }
83              
84 0           my $soap_content = $soap_content_obj->toString;
85              
86             # Please note there is currently no way to build a Net::UPnP::Service from scratch.
87             # Bug Reported: https://rt.cpan.org/Ticket/Display.html?id=91711
88              
89 0           my $post_res = Net::UPnP::HTTP->new->postsoap(
90             $self->host, #method from Power::Outlet::Common::IP
91             $self->port, #method from Power::Outlet::Common::IP
92             $self->http_path, #method from Power::Outlet::Common::HTTP
93             $soap_action,
94             $soap_content,
95             );
96              
97 0 0         die(sprintf("Error: HTTP Request failed. Status Code: %s", $post_res->getstatuscode)) unless $post_res->getstatuscode == 200;
98              
99 0           my $action_res = Net::UPnP::ActionResponse->new;
100 0           $action_res->sethttpresponse($post_res);
101              
102 0           return $action_res;
103             }
104              
105             =head1 BUGS
106              
107             Please log on RT and send an email to the author.
108              
109             =head1 SUPPORT
110              
111             DavisNetworks.com supports all Perl applications including this package.
112              
113             =head1 AUTHOR
114              
115             Michael R. Davis
116             CPAN ID: MRDVT
117             DavisNetworks.com
118              
119             =head1 COPYRIGHT
120              
121             Copyright (c) 2013 Michael R. Davis
122              
123             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
124              
125             The full text of the license can be found in the LICENSE file included with this module.
126              
127             Portions of the UPnP Implementation Copyright (c) 2013 Eric Blue
128              
129             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
130              
131             =head1 SEE ALSO
132              
133             L, L
134              
135             =cut
136              
137             1;