#!/usr/bin/perl
# Copyright 1999-2002 Gentoo Technologies, Inc.
# Distributed under the terms of the GNU General Public License, v2 or later
# $Header: $

use LWP::UserAgent;
use HTTP::Request::Common;
use strict;


our %config;


sub get_client_md5
{
  my $md5;

  $md5 = `/usr/bin/md5sum /usr/sbin/gentoo-stats`;
  $md5 =~ s|(.*)[ \t]+.*|\1|s;

  return $md5;
}


sub get_dir_entries
{
  my $dir = $_[0];
  my @dirs;
  my @newdirs;

  opendir(DIR, $dir) || die('couldn\'t read ' . $dir);
  @dirs = readdir(DIR);
  closedir(DIR);

  foreach $dir (@dirs)
  {
    if (!($dir =~ /^[\.]{1,2}$/))
    {
      push(@newdirs, $dir);
    }
  }

  return @newdirs;
}


sub get_packages
{
  my @categories;
  my $category;
  my @packages;
  my $package;
  my $all_packages = '';

  if (%config->{'SUBMIT_PACKAGES'} == 0)
  {
    return '';
  }

  @categories = get_dir_entries('/var/db/pkg');
  foreach $category (@categories)
  {
    @packages = get_dir_entries('/var/db/pkg/' . $category);
    foreach $package (@packages)
    {
      $all_packages .= $category . '/' . $package . "\n";
    }
  }

  return $all_packages;
}


sub get_cpus_alpha
{
  my $cpus = join '', @_;
  $cpus =~ s/\|/\//g;	# remove our separator

  my %vendors = qw(
    Alphabook   Tadpole
    Brisbane    HP
    Granite     HP
    Marvel      HP
    Monet       Compaq
    Nautilus    API
    Privateer   HP
    Ruffian     Samsung
    Webbrick    Compaq
    Wildfire    Compaq
  );
	  

  # Notes:
  #  1. Digital is the default vendor unless there's another listed
  #     above.
  #  2. /proc/cpuinfo on alpha doesn't provide a listing for each
  #     processor, so we just multiply the first entry
  #  3. We put the system variation in the flags entry for interest's
  #     sake.
  $cpus =~ s{\A
	(?=.*?^platform.string     \s*:.(.*?)$)  # not used atm
	(?=.*?^system.variation    \s*:.(.*?)$)  # =flags
	(?=.*?^cpu.model           \s*:.(.*?)$)  # EV*
	(?=.*?^cycle.frequency..Hz.\s*:.(.*?)$)  # in Hz
	(?=.*?^cpus.detected       \s*:.(.*?)$)  # used to multply the string
	(?=.*?^system.type         \s*:.(.*?)$)  # needed for Ruffian
	.*\Z
  }{
	sprintf("%s|Alpha %s|%.0f|%s\n", ($vendors{$2||$6} || 'Digital'), 
	        $3, $4/1000000, ($2||$6)) x ($5||1)
  }xsme or $cpus = "Unknown|Alpha|Unknown|";

  return $cpus;
}


sub get_cpus_ppc
{
  my @lines = @_;
  my $x;
  my $cpus = '';
  my $vendor = '';
  my $modelname = '';
  my $mhz = '';
  my $flags = '';

  foreach my $line (@lines)
  {
	$line =~ s/[\r\n]//g;

	if ($line =~ /^cpu/)
	{
	  if (length($modelname) > 0)
	  {
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $modelname) = split(/:/, $line);
	  $modelname =~ s/^[ \t]+//;
	  $modelname =~ s/[ \t]+$//;

	  if ($modelname =~ /altivec/)
	  {
		$flags = 'altivec';
	  }
	  $modelname =~ s/^([^,]+),.*$/\1/;
	}
	elsif ($line =~ /^clock/)
	{
	  if (length($mhz) > 0)
	  {
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $mhz) = split(/:/, $line);
	  $mhz =~ s/^[ \t]+//;
	  $mhz =~ s/[ \t]+$//;
	  if ($mhz =~ /^[0-9]+MHz$/)
	  {
		$mhz =~ s/^([0-9]+)MHz$/\1/;
	  }
	  else
	  {
		$mhz = '';
	  }
	}

	if ((length($modelname) > 0) && (length($mhz) > 0))
	{
	  $modelname =~ s/|//g;
	  $cpus .= "Power Macintosh|$modelname|$mhz|$flags\n";
	}
  }

  return $cpus;
}


sub get_cpus_x86
{
  my @lines = @_;
  my $x;
  my $cpus = '';
  my $vendor = '';
  my $modelname = '';
  my $mhz = '';
  my $flags = '';

  foreach my $line (@lines)
  {
	$line =~ s/[\r\n]//g;

	if ($line =~ /^vendor_id/)
	{
	  if (length($vendor) > 0)
	  {
		$vendor = '';
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $vendor) = split(/:/, $line);
	  $vendor =~ s/^[ \t]+//;
	  $vendor =~ s/[ \t]+$//;
	}
	elsif ($line =~ /^model name/)
	{
	  if (length($modelname) > 0)
	  {
		$vendor = '';
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $modelname) = split(/:/, $line);
	  $modelname =~ s/^[ \t]+//;
	  $modelname =~ s/[ \t]+$//;
	}
	elsif ($line =~ /^cpu MHz/)
	{
	  if (length($mhz) > 0)
	  {
		$vendor = '';
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $mhz) = split(/:/, $line);
	  $mhz =~ s/^[ \t]+//;
	  $mhz =~ s/[ \t]+$//;
	}
	elsif ($line =~ /^flags/)
	{
	  if (length($flags) > 0)
	  {
		$vendor = '';
		$modelname = '';
		$mhz = '';
		$flags = '';
	  }

	  ($x, $flags) = split(/:/, $line);
	  $flags =~ s/^[ \t]+//;
	  $flags =~ s/[ \t]+$//;
	}

	if ((length($vendor) > 0) &&
	  (length($modelname) > 0) &&
	  (length($mhz) > 0) &&
	  (length($flags) > 0))
	{
	  $vendor =~ s/|//g;
	  $modelname =~ s/|//g;
	  $mhz =~ s/|//g;
	  $flags =~ s/|//g;
	  $cpus .= "$vendor|$modelname|$mhz|$flags\n";

	  $vendor = '';
	  $modelname = '';
	  $mhz = '';
	  $flags = '';
	}
  }

  return $cpus;
}


sub get_cpus
{
  my @lines;

  if (%config->{'SUBMIT_CPU'} == 0)
  {
    return '';
  }

  open(FILE, '/proc/cpuinfo') || die('couldn\'t open /proc/cpuinfo');
  @lines = <FILE>;
  close(FILE);

  # detect platform type
  for my $line (@lines) {
	if ($line =~ /^machine.*(PowerMac|PowerBook|Power Macintosh)/) {
	  return get_cpus_ppc(@lines);
	}
	if ($line =~ /^cpu\s*: Alpha/) {
	  return get_cpus_alpha(@lines);
	}
  }
  
  # assume x86
  return get_cpus_x86(@lines);
}


sub get_mem_total
{
  my @lines;
  my $line;
  my $x;
  my $x2;
  my $mem_total = '';

  if (%config->{'SUBMIT_MEMORY'} == 0)
  {
    return '';
  }

  open(FILE, '/proc/meminfo') || die('couldn\'t open /proc/meminfo');
  @lines = <FILE>;
  close(FILE);

  foreach $line (@lines)
  {
    $line =~ s/[\r\n]//g;
    if ($line =~ /^Mem:/)
    {
      $line =~ s/\t/ /g;
      $line =~ s/[ ]{2,}/ /g;
      ($x, $mem_total, $x2) = split(/ /, $line);

      last;
    }
  }

  # no "Mem:", let's try with "MemTotal:" then (note kB)
  if ($mem_total eq '')
  {
    foreach $line (@lines)
    {
      if ($line =~ /^MemTotal:[ \t]*[0-9]+[ \t]+kB/)
      {
        $line =~ s/^MemTotal:[ \t]*([0-9]+)[ \t]+kB$/\1/;
        $mem_total = $line * 1024;
        last;
      }
    }
  }

  return $mem_total;
}


sub get_swap_total
{
  my @lines;
  my $line;
  my $x;
  my $x2;
  my $swap_total = '';

  if (%config->{'SUBMIT_MEMORY'} == 0)
  {
    return '';
  }

  open(FILE, '/proc/meminfo') || die('couldn\'t open /proc/meminfo');
  @lines = <FILE>;
  close(FILE);

  foreach $line (@lines)
  {
    $line =~ s/[\r\n]//g;
    if ($line =~ /^Swap:/)
    {
      $line =~ s/\t/ /g;
      $line =~ s/[ ]{2,}/ /g;
      ($x, $swap_total, $x2) = split(/ /, $line);

      last;
    }
  }

  # no "Swap:", let's try with "SwapTotal:" then (note kB)
  if ($swap_total eq '')
  {
    foreach $line (@lines)
    {
      if ($line =~ /^SwapTotal:[ \t]*[0-9]+[ \t]+kB/)
      {
        $line =~ s/^SwapTotal:[ \t]*([0-9]+)[ \t]+kB$/\1/;
        $swap_total = $line * 1024;
        last;
      }
    }
  }

  return $swap_total;
}


sub get_cards
{
  my $c;
  my @c2;
  my $num;
  my $i;
  my $cards;
  my $class = '';
  my $vendor = '';
  my $device = '';
  my $x;

  if (%config->{'SUBMIT_CARDS'} == 0)
  {
    return '';
  }

  $c = `/sbin/lspci -m -v`;
  $c =~ s/\r//s;
  @c2 = split(/\n/, $c);
  $cards = '';
  foreach $c (@c2)
  {
    if ((($c =~ /^$/) ||
         ($c =~ /^(Class|Device|Vendor):/)) &&
        !($c =~ /^Device:[ \t]+[0-9a-f][0-9a-f]:[0-9a-f][0-9a-f]\.[0-9a-f]/))
    {
      $cards .= $c . "\n";
    }
  }

  @c2 = split(/\n/, $cards);
  $cards = '';
  foreach $c (@c2)
  {
    if ($c =~ /^Class/)
    {
      if (length($class) > 0)
      {
        $class = '';
        $vendor = '';
        $device = '';
      }

      ($x, $class) = split(/:/, $c);
      $class =~ s/^[ \t]+//;
      $class =~ s/[ \t]+$//;
    }
    elsif ($c =~ /^Vendor/)
    {
      if (length($vendor) > 0)
      {
        $class = '';
        $vendor = '';
        $device = '';
      }

      ($x, $vendor) = split(/:/, $c);
      $vendor =~ s/^[ \t]+//;
      $vendor =~ s/[ \t]+$//;
    }
    elsif ($c =~ /^Device/)
    {
      if (length($device) > 0)
      {
        $class = '';
        $vendor = '';
        $device = '';
      }

      ($x, $device) = split(/:/, $c);
      $device =~ s/^[ \t]+//;
      $device =~ s/[ \t]+$//;
    }

    if ((length($class) > 0) &&
        (length($vendor) > 0) &&
        (length($device) > 0))
    {
      $class =~ s/|//g;
      $vendor =~ s/|//g;
      $device =~ s/|//g;
      $cards .= $class . '|' . $vendor . '|' . $device . "\n";

      $class = '';
      $vendor = '';
      $device = '';
    }
  }

  return $cards;
}


sub get_profile
{
  my $profile;

  if (%config->{'SUBMIT_PROFILE'} == 0)
  {
    return '';
  }

  $profile = readlink('/etc/make.profile');
  $profile =~ s|.*/([^/]+)[/]?$|\1|;

  return $profile;
}


sub load_config
{
  my %conf = ();
  my @lines;
  my $line;
  my $key;
  my $val;

  %conf->{'SYSTEM_ID'} = '';
  %conf->{'SYSTEM_NAME'} = '';
  %conf->{'SUBMIT_PACKAGES'} = 1;
  %conf->{'SUBMIT_CPU'} = 1;
  %conf->{'SUBMIT_MEMORY'} = 1;
  %conf->{'SUBMIT_CARDS'} = 1;
  %conf->{'SUBMIT_PROFILE'} = 1;
  %conf->{'EMAIL'} = '';
  %conf->{'ALLOW_DEVS'} = 0;
  %conf->{'HTTP_PROXY'} = '';

  open(FILE, '/etc/gentoo-stats/gentoo-stats.conf') ||
    die('couldn\'t open /etc/gentoo-stats/gentoo-stats.conf');
  @lines = <FILE>;
  close(FILE);

  foreach $line (@lines)
  {
    $line =~ s/[\r\n]//g;

    # search for lines like these only:
    #   XYZ=foo
    #   ABC="bar"
    if ($line =~ /([A-Z_]+="[^"]*"|[A-Z_]+=.*)/)
    {
      $line =~ s/([A-Z_]+=)"([^"]*)"/\1\2/;   # remove quotes around value
      ($key, $val) = split(/=/, $line);

      if ($key eq 'SYSTEM_ID')
      {
        %conf->{'SYSTEM_ID'} = $val;
      }
      elsif ($key eq 'SYSTEM_NAME')
      {
        %conf->{'SYSTEM_NAME'} = $val;
      }
      elsif (($key eq 'SUBMIT_PACKAGES') && ($val ne 'yes'))
      {
        %conf->{'SUBMIT_PACKAGES'} = 0;
      }
      elsif (($key eq 'SUBMIT_CPU') && ($val ne 'yes'))
      {
        %conf->{'SUBMIT_CPU'} = 0;
      }
      elsif (($key eq 'SUBMIT_MEMORY') && ($val ne 'yes'))
      {
        %conf->{'SUBMIT_MEMORY'} = 0;
      }
      elsif (($key eq 'SUBMIT_CARDS') && ($val ne 'yes'))
      {
        %conf->{'SUBMIT_CARDS'} = 0;
      }
      elsif (($key eq 'SUBMIT_PROFILE') && ($val ne 'yes'))
      {
        %conf->{'SUBMIT_PROFILE'} = 0;
      }
      elsif ($key eq 'EMAIL')
      {
        %conf->{'EMAIL'} = $val;
      }
      elsif (($key eq 'ALLOW_DEVS') && ($val eq 'yes'))
      {
        %conf->{'ALLOW_DEVS'} = 1;
      }
      elsif ($key eq 'HTTP_PROXY')
      {
        %conf->{'HTTP_PROXY'} = $val;
      }
    }
  }

  return %conf;
}


sub show_usage
{
  print "Usage: gentoo-stats --new\n" .
        "       gentoo-stats --update [SYSTEMID]\n\n" .
        "--new\n" .
        "\tRequest new monitoring ID for this system.\n\n" .
        "--update [SYSTEMID]\n" .
        "\tSubmit statistics data to server. Note that providing a system ID\n" .
        "\ton the command line is deprecated. You should put your system ID\n" .
        "\tinto /etc/gentoo-stats/gentoo-stats.conf\n\n\n" .
        "NOTE: Please only request exactly one system ID per entire system\n" .
        "      (regardless of the number of CPUs it might have). Thanks.\n\n\n" .
        "The Gentoo Linux usage statistics are available at:\n" .
        "http://stats.gentoo.org\n";
}


sub obtain_new_id
{
  my $ua;
  my $resp;
  my $s;

  print "Obtaining new system ID...\n";

  $ua = LWP::UserAgent->new();
  if (%config->{'HTTP_PROXY'} ne '')
  {
    $ua->proxy('http', %config->{'HTTP_PROXY'});
  }
  $resp = $ua->request(GET 'http://stats.gentoo.org/servlet/org.gentoo.stats.NewUserServlet');
  $s = $resp->content;

  if ($s =~ /Your new system ID is/s)
  {
    $s =~ s/Your new system ID is: (.*)[\r\n].*/$1/s;

    print "\nYour new system ID is: " . $s . "\n\n";

    print "Updating statistics for the first time...\n";
    %config->{'SYSTEM_ID'} = $s;
    update_statistics();

    print "Inserting your system ID into /etc/gentoo-stats/gentoo-stats.conf...\n";
    if (insert_id_config() != 0)
    {
      print "Could not insert your system ID into /etc/gentoo-stats/gentoo-stats.conf.\n" .
            "Please revisit this file and insert your system ID manually.\n";
    }

    print "\nYou should run gentoo-stats at regular intervals.\n" .
          "Run it from a cron daemon like this:\n\n" .
          "0 0 * * 0,4 /usr/sbin/gentoo-stats --update >/dev/null\n\n\n" .
          "Thanks for participating!\n";
  }
  else
  {
    print "There was an error when obtaining a new system ID (proxy?).\n" .
          "Please try again later.\n";
  }
}

sub insert_id_config
{
  my $rc = 1;

  unlink('/etc/gentoo-stats/gentoo-stats.conf.old');
  rename('/etc/gentoo-stats/gentoo-stats.conf', '/etc/gentoo-stats/gentoo-stats.conf.old');

  open(FILE, '/etc/gentoo-stats/gentoo-stats.conf.old') or goto failed;
  open(NEWFILE, '>/etc/gentoo-stats/gentoo-stats.conf') or goto failed2;

  while (<FILE>)
  {
    s/[\r\n]//g;
    if (/^SYSTEM_ID="[^"]*"$/ || /^SYSTEM_ID=[^"]*$/)
    {
      print NEWFILE 'SYSTEM_ID="' . %config->{'SYSTEM_ID'} . "\"\n";
    }
    else
    {
      print NEWFILE $_ . "\n";
    }
  }

  $rc = 0;

  close(NEWFILE);

  failed2:
  close(FILE);

  failed:
  return $rc;
}


sub update_statistics
{
  my $ua;
  my $resp;

  if (%config->{'SYSTEM_ID'} eq '')
  {
    print STDERR "gentoo-stats: no system ID specified, please revisit\n" .
                 "              /etc/gentoo-stats/gentoo-stats.conf\n";
    return 1;
  }

  $ua = LWP::UserAgent->new();
  if (%config->{'HTTP_PROXY'} ne '')
  {
    $ua->proxy('http', %config->{'HTTP_PROXY'});
  }
  $resp = $ua->request(POST 'http://stats.gentoo.org/servlet/org.gentoo.stats.StatsServlet',
    [
      protocol => '4',
      client_md5 => get_client_md5(),
      id => %config->{'SYSTEM_ID'},
      system_name => %config->{'SYSTEM_NAME'},
      packages => get_packages(),
      cpus => get_cpus(),
      mem_total => get_mem_total(),
      swap_total => get_swap_total(),
      cards => get_cards(),
      profile => get_profile(),
      email => %config->{'EMAIL'},
      allow_devs => %config->{'ALLOW_DEVS'}
    ]);

  return $resp->content;
}


sub main
{
  my $num_args = $#ARGV + 1;
  my $arg0 = $ARGV[0];
  my $arg1 = $ARGV[1];
  my $ua;
  my $resp;
  my $s;

  if ($num_args == 0)
  {
    show_usage();
    return 1;
  }

  %config = load_config();

  if ($arg0 =~ /^--new$/)
  {
    obtain_new_id();
  }
  elsif ($arg0 =~ /^--update$/)
  {
    if ((%config->{'SYSTEM_ID'} eq '') && ($num_args == 2))
    {
      %config->{'SYSTEM_ID'} = $arg1;
    }

    print(update_statistics());
  }
  else
  {
    show_usage();
    return 1;
  }

  return 0;
}


exit(main());