Test::AutoBuild::Platform - represents a build host's environment

  use Test::AutoBuild::Platform;

  # Create a new platform based on the host machine's native
  # environment
  my $platform = Test::AutoBuild::Platform->new(name => "host");




  # Or create a platform describing a chroot environment which
  # has a differing OS, but same architecture
  my $platform = Test::AutoBuild::Platform->new(name => "host",
						label => "Fedora Core 3");

  # Or create a platform describing an emulated OS
  my $platform = Test::AutoBuild::Platform->new(name => "host",
						label => "Free BSD",
						operating_system => "bsd",
						architecture => "x86_64");

  # Create a platform describing the host, with some 'interesting'
  # extra metadata about the toolchain
  my $platform = Test::AutoBuild::Platform->new(name => "host",
						options => {
	  'compiler.cc' => "GCC 3.2.3",
	  'compiler.c++' => "G++ 3.2.3",
	  'linker' => "GNU LD 2.15",
	});

# -*- perl -*-
#
# Test::AutoBuild::Platform
#
# Daniel Berrange <dan@berrange.com>
# Dennis Gregorovic <dgregorovic@alum.mit.edu>
#
# Copyright (C) 2005 Daniel Berrange
#
# 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 2 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# $Id: Platform.pm,v 1.4 2007/12/08 17:35:16 danpb Exp $

package Test::AutoBuild::Platform;

use warnings;
use strict;
use Log::Log4perl;

use File::Spec::Functions qw(catfile rootdir);
use POSIX qw(uname);

use Class::MethodMaker
  get_set => [qw(
		name
		label
		architecture
		operating_system
		 )];

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    my %params = @_;

    $self->{options} = exists $params{options} ? $params{options} : {};

    bless $self, $class;

    $self->name(exists $params{name} ? $params{name} : die "name parameter is required");
    $self->label(exists $params{label} ? $params{label} : $self->_guess_host_label());
    $self->architecture(exists $params{architecture} ? $params{architecture} : $self->_guess_architecture());
    $self->operating_system(exists $params{operating_system} ? $params{operating_system} : $self->_guess_operating_system());

    return $self;
}

sub _guess_host_label {
    my $self = shift;

    my $issue = catfile(rootdir, "etc", "issue");
    if (-f $issue) {
	open ISSUE, "<$issue"
	    or die "cannot read $issue: $!";

	# Yes there is often > 1 line in /etc/issue
	# be we only care about a short descriptive
	# label, for which the first line will be
	# sufficient
	my $line = <ISSUE>;
	close ISSUE;

	chomp $line;
	return $line;
    } else {
	my ($sysname, $nodename, $release, $version, $machine) = uname();

	return "$sysname $release $version ($machine)";
    }
}

sub _guess_architecture {
    my $self = shift;
    my ($sysname, $nodename, $release, $version, $machine) = uname();

    return $machine;
}


sub _guess_operating_system {
    my $self = shift;
    my ($sysname, $nodename, $release, $version, $machine) = uname();

    return $sysname;
}

sub option {
   my $self = shift;
   my $name = shift;

   $self->{options}->{$name} = shift if @_;

   return $self->{options}->{$name};
}

sub options {
    my $self = shift;
    return keys %{$self->{options}};
}

1; # So that the require or use succeeds.

__END__