Test::AutoBuild::Runtime - Builder runtime state

  use Test::AutoBuild::Runtime;

  my $runtime = new Test::AutoBuild::Runtime (archive_manager => $archive_manager,
					      monitors => \%monitors,
					      repositories => \%repositories,
					      modules => \%modules,
					      package_types => \%package_types,
					      publishers => \%publishers,
					      groups => \%groups,
					      platforms => \%platforms,
					      source_root => $dir,
					      install_root => $dir,
					      package_root => $dir,
					      log_root => $dir,
					      counter => $counter);

  my $archive = $runtime->archive;

  my @monitor_names = $runtime->monitors;
  my @repository_names = $runtime->repositories;
  my @module_names = $runtime->modules;
  my @package_types_names = $runtime->package_types;
  my @publisher_names = $runtime->publishers;
  my @group_names = $runtime->groups;
  my @platform_names = $runtime->platforms;

  my $monitor = $runtime->monitor($name);
  my $repository = $runtime->repository($name);
  my $module = $runtime->module($name);
  my $package_type = $runtime->package_type($name);
  my $publisher = $runtime->publisher($name);
  my $group = $runtime->group($name);
  my $platform = $runtime->platform($name);

  $runtime->attribute($key, $value);
  my $value = $runtime->attribute($key);
  my %attributes = $runtime->attributes()

  my $dir = $runtime->source_root();
  my $dir = $runtime->install_root();
  my $dir = $runtime->package_root();
  my $dir = $runtime->log_root();

# -*- perl -*-
#
# Test::AutoBuild::Runtime by Dan Berrange
#
# Copyright (C) 2005 Dan 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: Runtime.pm,v 1.19 2007/12/08 17:35:16 danpb Exp $

package Test::AutoBuild::Runtime;

use warnings;
use strict;
use Carp qw(confess);
use Log::Log4perl;
use Sys::Hostname;
use File::Spec::Functions;
use List::Util qw(shuffle);
use Class::MethodMaker
    new_with_init => qw(new),
    get_set => [qw(
		   counter
		   timestamp
		   source_root
		   install_root
		   package_root
		   log_root
		   admin_email
		   admin_name
		   archive_manager
		   group_email
		   group_name
		   )];

our $VERSION = "1.1.0";

sub init {
    my $self = shift;
    my %params = @_;

    $self->{monitors} = exists $params{monitors} ? $params{monitors} : {};
    $self->{repositories} = exists $params{repositories} ? $params{repositories} : {};
    $self->{modules} = exists $params{modules} ? $params{modules} : {};
    $self->{package_types} = exists $params{package_types} ? $params{package_types} : {};
    $self->{publishers} = exists $params{publishers} ? $params{publishers} : {};
    $self->{groups} = exists $params{groups} ? $params{groups} : {};
    $self->{platforms} = exists $params{platforms} ? $params{platforms} : {};
    $self->{attributes} = {};

    $self->timestamp(exists $params{timestamp} ? $params{timestamp} : time);
    $self->source_root(exists $params{source_root} ? $params{source_root} : catfile($ENV{HOME}, "source-root"));
    $self->install_root(exists $params{install_root} ? $params{install_root} : catfile($ENV{HOME}, "install-root"));
    $self->package_root(exists $params{package_root} ? $params{package_root} : catfile($ENV{HOME}, "package-root"));
    $self->log_root(exists $params{log_root} ? $params{log_root} : catfile($ENV{HOME}, "log-root"));
    $self->counter(exists $params{counter} ? $params{counter} : confess "counter parameter is required");
    $self->archive_manager(exists $params{archive_manager} ? $params{archive_manager} : undef);

#    $self->admin_email(exists $params{admin_email} ? $params{admin_email} : confess "admin_email parameter is required");
    $self->admin_email(exists $params{admin_email} ? $params{admin_email} : "root\@" . hostname());
    $self->admin_name(exists $params{admin_name} ? $params{admin_name} : "Build Administrator");
    $self->group_email(exists $params{group_email} ? $params{group_email} : $self->admin_email);
    $self->group_name(exists $params{group_name} ? $params{group_name} : $self->admin_name);

    $self->_sort_modules();
}

sub _sort_modules {
    my $self = shift;

    my $order = [];

    my %pairs;  # all pairs ($l, $r)
    my %npred;  # number of predecessors
    my %succ;   # list of successors

    # tsort code by Jeffrey S. Haemer, <jsh@boulder.qms.com>
    # SEE ALSO tsort(1), tcsh(1), tchrist(1)
    # Algorithm stolen from Jon Bentley (I<More Programming Pearls>, pp. 20-23),
    # Who, in turn, stole it from Don Knuth
    # (I<Art of Computer Programming, volume 1: Fundamental Algorithms>,
    # Section 2.2.3)

    foreach my $name ($self->modules) {
	my $depends = $self->module($name)->depends();
	if ($#{$depends} > -1) {
	    foreach my $depmod (@{$depends}) {
		die "module $name depends on non-existent module $depmod"
		    unless defined $self->modules($depmod);
		next if defined $pairs{$depmod}{$name};
		$pairs{$depmod}{$name}++;
		$npred{$depmod} += 0;
		$npred{$name}++;
		push @{$succ{$depmod}}, $name;
	    }
	} else {
	    $pairs{$name}{$name}++;
	    $npred{$name} += 0;
	    push @{$succ{$name}}, $name;
	}
    }
    # create a list of nodes without predecessors
    my @list = shuffle(grep {!$npred{$_}} keys %npred);
    while (@list) {
	$_ = pop @list;
	push @{$order}, $_;
	foreach my $child (@{$succ{$_}}) {
	    # depth-first (default)
	    push @list, $child unless --$npred{$child};
	}
    }

    $self->{sorted_modules} = $order;
}

sub archive {
    my $self = shift;
    return $self->archive_manager ?
	$self->archive_manager->get_current_archive($self) :
	undef;
}

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

sub monitor {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{monitors}->{$name}) {
	confess "no monitor called $name";
    }
    return $self->{monitors}->{$name};
}

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

sub repository {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{repositories}->{$name}) {
	confess "no repository called $name";
    }
    return $self->{repositories}->{$name};
}

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

sub sorted_modules {
    my $self = shift;
    return @{$self->{sorted_modules}};
}

sub module {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{modules}->{$name}) {
	confess "no module called $name";
    }
    return $self->{modules}->{$name};
}

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

sub package_type {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{package_types}->{$name}) {
	confess "no package_type called $name";
    }
    return $self->{package_types}->{$name};
}

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

sub publisher {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{publishers}->{$name}) {
	confess "no publisher called $name";
    }
    return $self->{publishers}->{$name};
}

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

sub group {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{groups}->{$name}) {
	confess "no group called $name";
    }
    return $self->{groups}->{$name};
}

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

sub platform {
    my $self = shift;
    my $name = shift;
    if (!exists $self->{platforms}->{$name}) {
	confess "no platform called $name";
    }
    return $self->{platforms}->{$name};
}


sub host_platform {
    my $self = shift;
    foreach my $name ($self->platforms) {
	my $platform = $self->platform($name);
	if ($platform->name eq "host") {
	    return $platform;
	}
    }
    die "cannot locate host platform";
}

sub attribute {
    my $self = shift;
    my $name = shift;
    $self->{attributes}->{$name} = shift if @_;
    return $self->{attributes}->{$name};
}

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

sub build_counter {
    my $self = shift;
    $self->{build_counter} = $self->counter->generate($self) unless defined $self->{build_counter};
    return $self->{build_counter};
}



sub module_admin_email {
    my $self = shift;
    my $module = shift;
    return $module->admin_email ? $module->admin_email : $self->admin_email;
}


sub module_admin_name {
    my $self = shift;
    my $module = shift;
    return $module->admin_name ? $module->admin_name : $self->admin_name;
}


sub module_group_email {
    my $self = shift;
    my $module = shift;
    return $module->group_email ? $module->group_email : $self->group_email;
}


sub module_group_name {
    my $self = shift;
    my $module = shift;
    return $module->group_name ? $module->group_name : $self->group_name;
}

sub notify {
    my $self = shift;
    my $event_name = shift;
    my @args = @_;

    foreach my $name ($self->monitors) {
	$self->monitor($name)->notify($event_name, @args);
    }
}

sub package_snapshot {
    my $self = shift;

    my $packages = {};
    foreach my $name ($self->package_types) {
	my $packs = $self->package_type($name)->snapshot();

	map { $packages->{$_} = $packs->{$_} } keys %{$packs};
    }
    return $packages;
}

sub installed_snapshot {
    my $self = shift;

    my $install_package_type =
	Test::AutoBuild::PackageType->new(name => "install",
					  label => "Install root",
					  extension => '',
					  spool => $self->install_root);
    return $install_package_type->snapshot();
}

sub expand_macros {
    my $self = shift;
    my $value = shift;

    my %macros = (
	'm' => sub { $self->modules },
	'p' => sub { $self->package_types },
	'g' => sub { $self->groups },
	'r' => sub { $self->repositories },
	'h' => sub { hostname },
	'c' => sub { $self->counter },
    );

    if (@_) {
	my $restrictions = shift;
	$macros{m} = sub { $restrictions->{module}} if exists $restrictions->{module};
	$macros{p} = sub { $restrictions->{package_type}} if exists $restrictions->{package_type};
	$macros{g} = sub { $restrictions->{group}} if exists $restrictions->{group};
	$macros{r} = sub { $restrictions->{repository}} if exists $restrictions->{repository};
    }

    my @input = ($value);
    my @output;
    while (my $output = shift @input) {
	if ($output =~ /%(\w+)/) {
	    my $key = $1;
	    if (!exists $macros{$key}) {
		die "unknown macro %$key in $value";
	    }
	    my $code = $macros{$key};
	    my @macros = &$code;
	    foreach my $macro (@macros) {
		my $newoutput = $output;
		$newoutput =~ s/%$key/$macro/ex;
		push @input, $newoutput;
	    }
	} else {
	    push @output, $output;
	}
    }
    return @output;
}

sub get_shell_environment {
    my $self = shift;
    my $module = shift;

    my %env;

    $env{AUTO_BUILD_ROOT} = $self->install_root;
    $env{AUTO_BUILD_COUNTER} = $self->build_counter;

    # New style vars
    $env{AUTOBUILD_COUNTER} = $self->build_counter;
    $env{AUTOBUILD_TIMESTAMP} = $self->timestamp;
    $env{AUTOBUILD_INSTALL_ROOT} = $self->install_root;
    $env{AUTOBUILD_PACKAGE_ROOT} = $self->package_root;
    $env{AUTOBUILD_SOURCE_ROOT} = $self->source_root;
    $env{AUTOBUILD_MODULE} = $module->name;

    return %env;
}

1 # So that the require or use succeeds.

__END__