AHA

 view release on metacpan or  search on metacpan

example/lava_lamp.pl  view on Meta::CPAN

    info(Dumper($status));
}

# Logout, we are done
close_lamp($lamp);

store_status($status);

# ================================================================================================

sub info {
    if (open (F,">>$LOG_FILE")) {
        print F scalar(localtime),": ",join("",@_),"\n";
        close F;
    }
}

# List the status file
sub list {
    my $status = retrieve $STATUS_FILE;
    my $hist_entries = $status->{hist};
    for my $hist (@{$hist_entries}) {
        print scalar(localtime($hist->[0])),": ",$hist->[1] ? "On " : "Off"," -- ",$hist->[2]," : ",$hist->[3],"\n";
    }
    print "Content: ",Dumper($status) if $DEBUG;
    return 1;
} 

# Create empty status file if necessary
sub init_status {
    my $status = {};
    $status->{hist} = [];
    if (! -e $STATUS_FILE) {
        store $status,$STATUS_FILE;
    }
}

sub log_manual_switch {
    my $status = shift;
    my $is_on = shift;
    my $last = get_last_entry($status);
    if ($last && $is_on != $last->[1]) {
        # Change has been manualy in between the interval. Add an approx history entry
        update_status($status,$is_on,"manual",estimate_manual_time($status));
    }   
}

sub update_status {
    my $status = shift;
    my $is_on = shift;
    my $mode = shift;
    my $time = shift || time;
    my $label = shift;
    my $hist = $status->{hist};
    push @{$hist},[ $time, $is_on, $mode, $label];
    info($is_on ? "On " : "Off"," -- ",$mode, $label ? ": " . $label : "");
}

sub estimate_manual_time {
    my $status = shift;
    my $last_hist = get_last_entry($status);
    if ($last_hist) {
        my $now = time;
        my $last = $last_hist->[0];
        my $calc = $now - $MANUAL_DELTA;
        return $calc > $last ? $calc : $now - int(($now - $last) / 2);
    } else {
        return time - $MANUAL_DELTA;
    }
}

sub get_last_entry {
    my $status = shift;
    if ($status) {
        my $hist = $status->{hist};
        return  $hist && @$hist ? $hist->[$#{$hist}] : undef;
    }
    return undef;
}

sub check_on_period {
    my ($min,$hour,$wd) = (localtime)[1,2,6];
    my $day = qw(Sun Mon Tue Wed Thu Fri Sat)[$wd];
    my $periods = $LAMP_ON_TIME_TABLE->{$day};
    for my $period (@$periods) {
        my ($low,$high) = @$period;
        my ($lh,$lm) = split(/:/,$low);
        my ($hh,$hm) = split(/:/,$high);
        my $m = $hour * 60 + $min;
        return 1 if $m >= ($lh * 60 + $lm) && $m <= ($hh * 60 + $hm);
    }
    return 0;
}

sub lamp_on_for_too_long {
    my $status = shift;
    
    # Check if the lamp was on for more than max time in the duration now - max
    # time + 1 hour
    my $current = time;
    my $low_time = $current - $LAMP_MAX_TIME - $LAMP_REST_TIME;
    my $on_time = 0;
    my $hist = $status->{hist};
    my $i = $#{$hist};
    while ($current > $low_time && $i >= 0) {

example/lava_lamp.pl  view on Meta::CPAN

        $i--;
    }
    if ($on_time >= $LAMP_MAX_TIME) {
        info("Lamp was on for " . $on_time . "s in the last " . ($LAMP_MAX_TIME + $LAMP_REST_TIME) . "s and is switched off now"); 
        return 1;
    } else {
        return 0;
    }
}

sub read_config_file {
    my $file = shift;
    open (F,$file) || die "Cannot read config file ",$file,": ",$!;
    my $config = join "",<F>;
    close F;
    eval $config;
    die "Error evaluating $config: ",$@ if $@;    
}

sub delete_trigger {
    my $status = shift;
    delete $status->{trigger_mark};
    delete $status->{trigger_label};
}

sub set_trigger {
    my $status = shift;
    my $label = shift;
    $status->{trigger_mark} = 1;
    $status->{trigger_label} = $label;
}

sub has_trigger {
    return shift->{trigger_mark};
}

sub trigger_label {
    return shift->{trigger_label};
}

# ====================================================
# Status file handling including locking

my $status_fh;

sub fetch_status {
    open ($status_fh,"+<$STATUS_FILE") || die "Cannot open $STATUS_FILE: $!";
    $status = fd_retrieve($status_fh) || die "Cannot read $STATUS_FILE: $!";
    flock($status_fh,2);
    return $status;
}


sub store_status {
    my $status = shift;
    
    # Truncate history if necessary
    truncate_hist($status);
    # Store status and unlock
    seek($status_fh, 0, 0); truncate($status_fh, 0);
    store_fd $status,$status_fh;
    close $status_fh;    
}

sub truncate_hist {
    my $status = shift;

    my $hist = $status->{hist};
    my $len = scalar(@$hist);
    splice @$hist,0,$len - $MAX_HISTORY_ENTRIES if $len > $MAX_HISTORY_ENTRIES;
    $status->{hist} = $hist;
}

# ==========================================================================
# Customize the following call and class in order to use a different 
# switch than AVM AHA's
sub open_lamp {
    my $config = shift;
    my $name = shift || $config->{id};
    return new Lamp($name,
                    $config->{host},
                    $config->{password},
                    $config->{user});
}

sub close_lamp {
    my $lamp = shift;
    $lamp->logout();
}

package Lamp;

use AHA;

sub new { 
    my $class = shift;
    my $name = shift;
    my $host = shift;
    my $password = shift;
    my $user = shift;

    my $aha = new AHA($host,$password,$user);
    my $switch = new AHA::Switch($aha,$name);
    
    my $self = {
                aha => $aha,
                switch => $switch
               };
    return bless $self,$class;
}

sub is_on {
    shift->{switch}->is_on();
}

sub on { 
    shift->{switch}->on();
}

sub off { 
    shift->{switch}->off();
}

sub logout {
    shift->{aha}->logout();
}

=head1 LICENSE

lava_lampl.pl 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.

lib/AHA.pm  view on Meta::CPAN

User role for login. Only required if a role based login is configured for the
Fritz box

=back

If used without an hashref as argument, the first argument must be the host, 
the second the password and the third optionally the user.

=cut 

sub new {
    my $class = shift;
    my $self = {};
    my $arg1 = shift; 
    if (ref($arg1) ne "HASH") {
        $self->{host} = $arg1;
        $self->{password} = shift;
        $self->{user} = shift;
    } else {
        map { $self->{$_} = $arg1->{$_} } qw(host password user port);
    }

lib/AHA.pm  view on Meta::CPAN

}

=item $switches = $aha->list()

List all switches know to AHA. An arrayref with L<AHA::Switch> objects is
returned, one for each device. When no switch is registered an empty arrayref
is returned. 

=cut

sub list {
    my $self = shift;
    return [ map { new AHA::Switch($self,$_) }  (split /\s*,\s*/,$self->_execute_cmd("getswitchlist")) ];
}

=item $aha->is_on($ain)

Check, whether the switch C<$ain> is in state "on", in which case this methods
returns 1. If it is "off", 0 is returned. If the switch is not connected,
C<undef> is returned.

=cut

sub is_on {
    my $self = shift;
    return &_inval_check($self->_execute_cmd("getswitchstate",$self->_ain(shift)));
}

=item $aha->on($ain)

Switch on the switch with the name or AIN C<$ain>. 

=cut

sub on {
    my $self = shift;
    my $ain = $self->_ain(shift);
    return $self->_execute_cmd("setswitchon",$ain);
}

=item $aha->off($ain)

Switch off the switch with the name or AIN C<$ain>. 

=cut

sub off {
    my $self = shift;
    return $self->_execute_cmd("setswitchoff",$self->_ain(shift));
}

=item $is_present = $aha->is_present($ain)

Check whether the switch C<$ain> is present. This means, whether it is
registered at the Fritz Box at all in which case 1 is returned. If the switch
is not connected, 0 is returned.

=cut

sub is_present {
    my $self = shift;
    return $self->_execute_cmd("getswitchpresent",$self->_ain(shift));
}

=item $energy = $aha->energy($ain)

Get the amount of energy which has been consumed by the switch C<$ain> since
ever or since the reset of the energy statistics via the admin UI. The amount
is measured in Wh.

=cut 

sub energy {
    my $self = shift;
    return $self->_execute_cmd("getswitchenergy",$self->_ain(shift));
}

=item $power = $aha->power($ain)

Get the current power consumption of the switch C<$ain> in mW.
If the switch is not connected, C<undef> is returned.

=cut

sub power {
    my $self = shift;
    return &_inval_check($self->_execute_cmd("getswitchpower",$self->_ain(shift)));
}

=item $name = $aha->name($ain)

Get the symbolic name for the AIN given. In this case C<$ain> must be an real
AIN.

=cut 

sub name {
    my $self = shift;
    my $ain = shift || die "No AIN given for which to fetch the name"; 
    return $self->_execute_cmd("getswitchname",$ain);
}

=item $ain = $aha->ain($name)

This is the inverse method to C<name()>. It takes a symbolic name C<$name> as
argument and returns the AIN. If no such name is registered, an error is
raised. 

=cut

sub ain_by_name {
    my $self = shift;
    my $name = shift;
    my $map = $self->{ain_map};
    return $map->{$name} if $map->{$name};
    $self->_init_ain_map();
    my $ain = $self->{ain_map}->{$name};
    die "No AIN for '$name' found" unless $ain;
    return $ain;
}

=item $aha->logout()

Logout from the connected fritz.box in order to free up any resources. You 
can still use any other method on this object, in which case it is 
logs in again (which eats up some performance, of course)

=cut

sub logout {
    my $self = shift;
    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);

lib/AHA.pm  view on Meta::CPAN

=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};

lib/AHA.pm  view on Meta::CPAN

    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.

lib/AHA/Switch.pm  view on Meta::CPAN


=item $switch = new AHA::Switch($aha,$ain)

Create a new switch object. The first object must be an L<"AHA"> instance,
which is responsible for the HTTP communication. The second argument Many must
be an 8-digit AIN (actor id) or a symbolic name. This symbolic name
can be configured in the admin UI of the Fritz Box.

=cut

sub new {
    my $class = shift;
    my $aha = shift;
    my $self = {
                aha => $aha,
                ain => $aha->_ain(shift)
               };
    return bless $self,$class;
}

=item $ain = $switch->ain()

Get the AIN which this object represents.

=cut

sub ain {
    return shift->{ain};
}

=item $switch->is_on()

=item $switch->is_present()

=item $switch->on()

=item $switch->off()

lib/AHA/Switch.pm  view on Meta::CPAN

Same as the corresponding method in L<"AHA"> with the exception, that no
C<$ain> argument is required since it already has been given during
construction time

=back 

=cut

my %SUPPORTED_METHODS = (map { $_ => 1 } qw(is_on is_present on off energy power name));

sub AUTOLOAD {
    my $self = shift;
    ( my $method = $AUTOLOAD ) =~ s{.*::}{};
    die "Unknown method $method" unless $SUPPORTED_METHODS{$method};
    return $self->{aha}->$method($self->{ain});
}

use overload fallback => 1,
  '""' => sub { "[AIN " . shift->{ain} . "]" }; 

1;



( run in 0.236 second using v1.01-cache-2.11-cpan-a5abf4f5562 )