#!/usr/bin/perl
##########################################################################
# Thinkpad ACPI Battery Control
# Copyright 2011 Elliot Wolk
##########################################################################
# This program 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 3 of the License, or
# (at your option) any later version.
#
# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
##########################################################################
# Exposes inhibit charge, start/stop charge threshold, and force discharge
# through ACPI as an alternative to SMAPI, which is broken in W520, etc.
#
# Makes ACPI calls using the acpi_call kernel module, which is REQUIRED.
#
# Supports 2011-released thinkpads, and possibly later ones.
# Tested and works on: W520, T420, X220
# Tested and does NOT work on: T400, X201S
#
# Limitations/Known Issues:
# 1) you cant force discharge on battery, so balancing is still impossible
# 2) sometimes you cant convince a slice battery to charge before the main
#    ANYONE who figures out this second issue gets a cookie!
#    if my main is above 80, and my slice is at 80, my main charges.
#    i can inhibit the main, but i CANNOT trick the slice into charging
# 3) you can only inhibit for 720 minutes instead of 1440 minutes
#    this seems like a BIOS error
##########################################################################
use strict;
use warnings;
use File::Basename;

my $acpiCallDev = '/proc/acpi/call';
my @aslBases = (
  '\_SB.PCI0.LPC.EC.HKEY',
  '\_SB.PCI0.LPC0.EC0.HKEY',
  '\_SB.PCI0.LPCB.EC.HKEY',
  '\_SB.PCI0.LPCB.EC0.HKEY',
  '\_SB.PCI0.LPCB.H_EC.HKEY',
  '\_SB.PCI0.LPC0.EC.HKEY',
);

sub getMethod($$);
sub setMethod($$@);

sub readPeakShiftState($);
sub readInhibitCharge($);
sub readStartChargeThreshold($);
sub readStopChargeThreshold($);
sub readForceDischarge($);

sub writePeakShiftState($);
sub writeInhibitCharge($);
sub writeStartChargeThreshold($);
sub writeStopChargeThreshold($);
sub writeForceDischarge($);

sub getASLBase();
sub acpiCall($);
sub runAcpiCall($$);
sub acpiCallGet($$);
sub acpiCallSet($$);

sub revpadzero($$);

sub bitRangeToDec(\@$$);
sub parseArgDecToBin($);
sub parseStatusHexToBitArray($);
sub decToBin($);
sub binToDec($);
sub hexToBin($);
sub binToHex($);
sub synList(@);

our $verbose = 0;

my ($methodST, $methodSP, $methodIC, $methodFD, $methodPS) =
  ("ST", "SP", "IC", "FD", "PS");
my $methodSyns = {
  $methodST => synList ("st", "startThreshold", "start"),
  $methodSP => synList ("sp", "stopThreshold", "stop"),
  $methodIC => synList ("ic", "inhibitCharge", "inhibit"),
  $methodFD => synList ("fd", "forceDischarge"),
  $methodPS => synList ("ps", "peakShiftState"),
};

my $name = File::Basename::basename $0;
my $usage = "Usage:
  Show this message:
    $name [-h|--help]

  Get charge thresholds / inhibit charge / force discharge:
    $name [-v] -g $methodST <bat{1,2}>
    $name [-v] -g $methodSP <bat{1,2}>
    $name [-v] -g $methodIC <bat{1,2,0}>
    $name [-v] -g $methodFD <bat{1,2}>

  Set charge thresholds / inhibit charge / force discharge:
    $name [-v] -s $methodST <bat{1,2,0}> <percent{0,1-99}>
    $name [-v] -s $methodSP <bat{1,2,0}> <percent{0,1-99}>
    $name [-v] -s $methodIC <bat{1,2,0}> <inhibit{1,0}> [<min{0,1-720,65535}>]
    $name [-v] -s $methodFD <bat{1,2}> <discharge{1,0}> [<acbreak{1,0}>]

  Set peak shift state, which is mysterious and inhibits charge:
    $name [-v] -s $methodPS <inhibit{1,0}> [<min{0,1-1440,65535}>]

  Synonyms:
    $methodST -> $$methodSyns{$methodST}
    $methodSP -> $$methodSyns{$methodSP}
    $methodIC -> $$methodSyns{$methodIC}
    $methodFD -> $$methodSyns{$methodFD}
    $methodPS -> $$methodSyns{$methodPS}

  Options:
    -v           show ASL call and response
    <bat>        1 for main, 2 for secondary, 0 for either/both
    <min>        number of minutes, or 0 for never, or 65535 for forever
    <percent>    0 for default, 1-99 for percentage
    <inhibit>    1 for inhibit charge, 0 for stop inhibiting charge
    <discharge>  1 for force discharge, 0 for stop forcing discharge
    <acbreak>    1 for stop forcing when AC is detached, 0 for do not
    [] means optional: sets value to 0
";

my $noReadMethods = join "|", ($methodPS);
my $noBothReadMethods = join "|", ($methodST, $methodSP, $methodFD);
my $noBothWriteMethods = join "|", ($methodFD);

sub main(@){
  if(@_ == 1 and $_[0] =~ /^(-h|--help)$/){
    print $usage;
    exit 0;
  }
  if(@_ > 0 and $_[0] eq '-v'){
    $verbose = 1;
    shift;
  }
  my $cmd = shift() || '';
  my $method;
  my $methodSyn = shift() || '';
  for my $m(keys %$methodSyns){
    $method = $m if $methodSyn eq $m or $methodSyn =~ /^($$methodSyns{$m})$/;
  }
  die $usage if not defined $method or $cmd !~ /^(-g|-s)$/;

  my $bat;
  if($method eq $methodPS){
    $bat = 0;
  }else{
    $bat = shift;
  }
  die "<bat> missing or incorrect\n" if not defined $bat or $bat !~ /^0|1|2$/;

  if($cmd eq '-g' and @_ == 0){
    print getMethod($method, $bat) . "\n";
  }elsif($cmd eq '-s'){
    print setMethod($method, $bat, @_);
  }else{
    die $usage;
  }
}

sub getMethod($$){
  my $method = shift;
  my $bat = shift;

  if($method =~ /^($noReadMethods)$/){
    die "Cannot read $method\n";
  }
  if($bat == 0 and $method =~ /^($noBothReadMethods)$/){
    die "Cannot specify 'either/both' for reading $method\n";
  }

  $bat = parseArgDecToBin $bat;

  if($method eq $methodST){
    return readStartChargeThreshold(acpiCallGet 'BCTG', $bat);
  }elsif($method eq $methodSP){
    return readStopChargeThreshold(acpiCallGet 'BCSG', $bat);
  }elsif($method eq $methodIC){
    #this is actually reading peak shift state
    return readInhibitCharge(acpiCallGet 'PSSG', $bat);
  }elsif($method eq $methodFD){
    return readForceDischarge(acpiCallGet 'BDSG', $bat);
  }else{
    die $usage;
  }
}
sub setMethod($$@){
  my $method = shift;
  my $bat = shift;

  if($bat == 0 and $method =~ /^($noBothWriteMethods)$/){
    die "Cannot specify 'either/both' for writing $method\n";
  }

  my %info;
  $info{bat} = $bat;

  if($method =~ /^($methodIC|$methodPS)$/){
    $info{inhibit} = shift @_;
    if(not defined $info{inhibit} or $info{inhibit} !~ /^0|1$/){
      die "missing or invalid value for <inhibit>\n";
    }

    $info{min} = shift @_;
    $info{min} = 0 if not defined $info{min};
    ############################################################
    #they are shifting a bit somewhere; the limit should be 1440
    #the same range in peak-shift-state is used, except shifted to the left
    #the value returned by peak-shift-state is the REAL duration, though
    $info{min} *= 2 if $method eq $methodIC;
    ############################################################

    if($info{min} !~ /^\d+$/ or ($info{min} > 1440 and $info{min} != 65535)){
      die "invalid value for <min>\n";
    }
  }elsif($method =~ /^($methodFD)$/){
    $info{discharge} = shift @_;
    if(not defined $info{discharge} or $info{discharge} !~ /^0|1$/){
      die "missing or invalid value for <discharge>\n";
    }

    $info{acbreak} = shift @_;
    $info{acbreak} = 0 if not defined $info{acbreak};
    if($info{acbreak} !~ /^0|1$/){
      die "invalid value for <acbreak>\n";
    }
  }elsif($method =~ /^($methodST|$methodSP)$/){
    $info{percent} = shift @_;
    if(not defined $info{percent} or $info{percent} !~ /^\d+$/ or $info{percent} > 99){
      die "missing or invalid value for <percent>\n";
    }
  }
  die $usage if @_ > 0;

  %info = map {$_ => parseArgDecToBin $info{$_}} keys %info;

  if($method eq $methodST){
    acpiCallSet 'BCCS', writeStartChargeThreshold(\%info);
  }elsif($method eq $methodSP){
    acpiCallSet 'BCSS', writeStopChargeThreshold(\%info);
  }elsif($method eq $methodIC){
    acpiCallSet 'BICS', writeInhibitCharge(\%info);
  }elsif($method eq $methodFD){
    acpiCallSet 'BDSS', writeForceDischarge(\%info);
  }elsif($method eq $methodPS){
    acpiCallSet 'PSSS', writePeakShiftState(\%info);
  }else{
    die $usage;
  }
}

sub readInhibitCharge($){
  my @bits = parseStatusHexToBitArray $_[0];
  if($bits[5] != 1){
    die "<inhibit charge unsupported>\n";
  }
  my $val;
  if($bits[0] == 1){
    $val = "yes";
    my $min = bitRangeToDec @bits, 8, 23;
    if($min == 0){
      $val .= " (unspecified min)";
    }elsif($min == 65535){
      $val .= " (forever)";
    }else{
      $val .= " ($min min)";
    }
  }else{
    $val = "no";
  }

  return $val;
}
sub readStartChargeThreshold($){
  my @bits = parseStatusHexToBitArray $_[0];
  if($bits[8] != 1 and $bits[9] != 1){
    die "<start charge threshold unsupported>\n";
  }
  my $val = bitRangeToDec @bits, 0, 7;
  if($val == 0){
    $val .= " (default)";
  }elsif($val > 0 and $val < 100){
    $val .= " (relative percent)";
  }else{
    $val .= " (unknown)";
  }
  return $val;
}

sub readStopChargeThreshold($){
  my @bits = parseStatusHexToBitArray $_[0];
  if($bits[8] != 1 and $bits[9] != 1){
    die "<start charge threshold unsupported>\n";
  }
  my $val = bitRangeToDec @bits, 0, 7;
  if($val == 0){
    $val .= " (default)";
  }elsif($val > 0 and $val < 100){
    $val .= " (relative percent)";
  }else{
    $val .= " (unknown)";
  }
  return $val;
}

sub readForceDischarge($){
  my @bits = parseStatusHexToBitArray $_[0];
  if($bits[8] != 1 and $bits[9] != 1){
    die "<force discharge unsupported>\n";
  }
  my $val;
  if($bits[0] == 1){
    $val = 'yes';
  }else{
    $val = 'no';
  }
  if($bits[1] == 1){
    $val .= ' (break on AC detach)';
  }

  return $val;
}


sub writePeakShiftState($){
  my $info = shift;
  return reverse ''
    . revpadzero( 1, $$info{inhibit})
    . revpadzero( 3, 0)
    . revpadzero( 4, 0)
    . revpadzero(16, $$info{min})
    . revpadzero( 8, 0)
  ;
}

sub writeInhibitCharge($){
  my $info = shift;
  return reverse ''
    . revpadzero( 1, $$info{inhibit})
    . revpadzero( 3, 0)
    . revpadzero( 2, $$info{bat})
    . revpadzero( 2, 0)
    . revpadzero(16, $$info{min})
    . revpadzero( 8, 0)
  ;
}

sub writeStartChargeThreshold($){
  my $info = shift;
  return reverse ''
    . revpadzero( 8, $$info{percent})
    . revpadzero( 2, $$info{bat})
    . revpadzero(22, 0)
  ;
}

sub writeStopChargeThreshold($){
  my $info = shift;
  return reverse ''
    . revpadzero( 8, $$info{percent})
    . revpadzero( 2, $$info{bat})
    . revpadzero(22, 0)
  ;
}

sub writeForceDischarge($){
  my $info = shift;
  return reverse ''
    . revpadzero( 1, $$info{discharge})
    . revpadzero( 1, $$info{acbreak})
    . revpadzero( 6, 0)
    . revpadzero( 2, $$info{bat})
    . revpadzero(22, 0)
  ;
}

sub acpiCall($){
  my $call = shift;

  if(not -e $acpiCallDev){
    $ENV{'PATH'} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin';
    system "modprobe acpi_call";
  }
  if(not -e $acpiCallDev){
    die "Could not find $acpiCallDev. Is module acpi_call loaded?\n";
  }

  my $val;
  for my $aslBase(@aslBases) {
    $val = runAcpiCall $call, $aslBase;
    if($val !~ /Error: AE_NOT_FOUND/){
      print "Call    : $aslBase.$call\n" if $verbose;
      print "Response: $val\n" if $verbose;
      last;
    }else{
      $val = undef;
    }
  }

  die "Error: no ASL base found\n" if not defined $val;

  return $val;
}
sub runAcpiCall($$){
  my ($call, $aslBase) = @_;
  open FH, "> $acpiCallDev" or die "Cannot write to $acpiCallDev: $!";
  print FH "$aslBase.$call\n";
  close FH;

  open FH, "< $acpiCallDev" or die "Cannot read $acpiCallDev: $!";
  my $val = <FH>;
  close FH;

  return $val;
}
sub acpiCallGet($$){
  my ($method, $bits) = @_;
  my $call = "$method 0x" . binToHex($bits);
  my $val = acpiCall $call;
  if($val eq '0x80000000'){
    die "Call failure status returned: $val";
  }
  return $val;
}
sub acpiCallSet($$){
  my ($method, $bits) = @_;
  my $call = "$method 0x" . binToHex($bits);
  my $val = acpiCall $call;
  if($val eq '0x80000000'){
    die "Call failure status returned: $val";
  }
}

sub revpadzero($$){
  return reverse ('0' x ($_[0] - length $_[1]) . $_[1]);
}

sub bitRangeToDec(\@$$){
  my @bits = @{shift()};
  my $start = shift;
  my $end = shift;
  my $bin = reverse(join '', @bits[$start .. $end]);
  return binToDec $bin;
}
sub parseArgDecToBin($){
  my $dec = shift;
  die "not a positive integer: " . $dec . "\n\n$usage" if $dec !~ /^\d+$/;
  return decToBin $dec;
}
sub parseStatusHexToBitArray($){
  my $hex = shift;
  if($hex !~ /0x([0-9a-f]+)/i){
    my $msg = "Bad status returned: $hex\n";
    if($hex =~ /Error: AE_NOT_FOUND/){
      $msg .= ''
        . "ASL base not found for this machine\n"
        . "  {perhaps it does not have the ThinkPad ACPI interface}\n"
        . "ASL bases checked:\n  "
        . (join "\n  ", @aslBases)
        . "\n"
        ;
    }
    die $msg;
  }
  return split //, revpadzero 32, hexToBin($1);
}

sub decToBin($){
  my $bits = unpack("B32", pack("N", $_[0]));
  $bits =~ s/^0*//;
  return $bits;
}
sub binToDec($){
  return oct "0b$_[0]";
}
sub hexToBin($){
  return decToBin(oct "0x$_[0]");
}
sub binToHex($){
  return sprintf("%x", binToDec $_[0]);
}

sub synList(@){
  return join "|", ((map {"--$_"} @_), @_);
}
&main(@ARGV);