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