view release on metacpan or  search on metacpan

lib/AHA.pm  view on Meta::CPAN

    return unless $self->{sid};

    # Send a post request as defined in 
    # http://www.avm.de/de/Extern/files/session_id/AVM_Technical_Note_-_Session_ID.pdf
    my $req = HTTP::Request->new(POST => $self->{login_url});
    $req->content_type("application/x-www-form-urlencoded");
    my $login = "sid=".$self->{sid}."&security:command/logout=fcn";
    $req->content($login);
    my $resp = $self->{ua}->request($req);
    die "Cannot logout SID ",$self->{sid},": ",$resp->status_line unless $resp->is_success;
    print "--- Logout ",$self->{sid} if $DEBUG;
    delete $self->{sid};
}

=back 



=cut

# ======================================================================
# Private methods

# Decide whether an AIN or a name is given
sub _ain {
    my $self = shift;
    my $ain = shift || die "No AIN or name given";
    return $ain =~ /^\d{12}$/ ? $ain : $self->ain_by_name($ain);
}

# Execute a command as defined in 
# http://www.avm.de/de/Extern/files/session_id/AHA-HTTP-Interface.pdf
sub _execute_cmd {
    my $self = shift;
    my $cmd = shift || die "No command given";
    my $ain = shift;
    my $url = $self->{ws_url} . "?sid=" . $self->_sid() . "&switchcmd=" . $cmd;
    $url .= "&ain=" . $ain if $ain;
    my $resp  = $self->{ua}->get($url);    
    print ">>> $url\n" if $DEBUG;
    die "Cannot execute ",$cmd,": ",$resp->status_line unless $resp->is_success;
    my $c = $resp->content;
    chomp $c;
    print "<<< $c\n" if $DEBUG;
    return $c;
}

# Return the cached SID or perform the login as described in
# http://www.avm.de/de/Extern/files/session_id/AVM_Technical_Note_-_Session_ID.pdf
sub _sid {
    my $self = shift;
    
    return $self->{sid} if $self->{sid};
    
    # Get the challenge
    my $resp = $self->{ua}->get($self->{login_url});
    my $content = $resp->content();

    my $challenge = ($content =~ /<Challenge>(.*?)<\/Challenge>/ && $1);
    my $input = $challenge . '-' . $self->{password};
    Encode::from_to($input, 'ascii', 'utf16le');
    my $challengeresponse = $challenge . '-' . lc(Digest::MD5::md5_hex($input));

    # Send the challenge back with encoded password
    my $req = HTTP::Request->new(POST => $self->{login_url});
    $req->content_type("application/x-www-form-urlencoded");
    my $login = "response=$challengeresponse";
    if ($self->{user}) {
        $login .= "&username=" . $self->{user};
    }
    $req->content($login);
    $resp = $self->{ua}->request($req);
    if (! $resp->is_success()) {
        die "Cannot login to ", $self->{host}, ": ",$resp->status_line();
    }
    $content = $resp->content();
    $self->{sid} = ($content =~ /<SID>(.*?)<\/SID>/ && $1);
    print "-- Login, received SID ",$self->{sid} if $DEBUG;
    return $self->{sid};
}

# Initialize the reverse name -> AIN map
sub _init_ain_map {
    my $self = shift;
    my $devs = $self->list();
    $self->{ain_map} = {};
    for my $dev (@$devs) {
        $self->{ain_map}->{$self->name($dev->ain())} = $dev->ain();
    }    
}

# Convert "inval" to undef
sub _inval_check {
    my $ret = shift;
    return $ret eq "inval" ? undef : $ret;
}

=head1 LICENSE

AHA is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 2 of the License, or
(at your option) any later version.

AHA is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with AHA.  If not, see <http://www.gnu.org/licenses/>.

=head1 AUTHOR

roland@cpan.org

=cut

1;