[Midnightbsd-cvs] mports: magus.pl: First beta version.

[ctriv at midnightbsd.org]

Log Message:
-----------
First beta version.

Modified Files:
--------------
    mports/Tools/magus/slave:
        magus.pl (r1.1 -> r1.2)

-------------- next part --------------
Index: magus.pl
===================================================================
RCS file: /home/cvs/mports/Tools/magus/slave/magus.pl,v
retrieving revision 1.1
retrieving revision 1.2
diff -LTools/magus/slave/magus.pl -LTools/magus/slave/magus.pl -u -r1.1 -r1.2
--- Tools/magus/slave/magus.pl
+++ Tools/magus/slave/magus.pl
@@ -1,4 +1,42 @@
 #!/usr/local/bin/perl
+#
+# Copyright (c) 2007 Chris Reinhardt. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# 1. Redistributions of source code must retain the above copyright notice
+#    this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+#    notice, this list of conditions and the following disclaimer in the
+#    documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+# COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+# $MidnightBSD$
+# 
+# MAINTAINER=   ctriv at MidnightBSD.org
+#
+
+
+
+#
+# todo: wrap run_test in eval: make an exception an internal error result.
+#	docs
+#	logging
+#	setproctitle
+#	
 
 use strict;
 use warnings;
@@ -6,45 +44,41 @@
 
 use Magus;
 
+$SIG{INT} = sub { die "Caught SIGINT\n" };
+
 main(@ARGV);
- 
-  
+
 sub main {
   my $lock;
     
-  eval {
-    while (1) {
-      $lock = Magus::Lock->get_ready_lock();
-      
-      if (!$lock) {
-        # there's no more ports to test, sleep for a while and check again.
-        sleep($Magus::Config{'DoneWaitPeriod'});
-        next;
-      }
-      
-      print "Installing: " . $lock->port->name . "\n";
-              
-      install_depends($lock) || next;
-      run_test($lock);
-      $lock->delete;
+  while (1) {
+    $lock = Magus::Lock->get_ready_lock();
+    
+    if (!$lock) {
+      # there's no more ports to test, sleep for a while and check again.
+      sleep($Magus::Config{'DoneWaitPeriod'});
+      next;
     }
-  };
+    
+    run_test($lock);
+    $lock->delete;
+  }
+}
 
-  my $err = $@;
-  eval { $lock->delete if defined $lock && ref $lock !~ m/deleted/i; };
-  
-  die $err if $err;
+
+END {
+  Magus::Lock->search(machine => $Magus::Machine)->delete_all;
 }
 
 
 sub install_depends {
-  my ($lock) = @_;
+  my ($lock, $chroot) = @_;
   
   foreach my $depend ($lock->port->depends) {
     print "\tDep $depend\n";
     if (!$depend->current_result || $depend->current_result->summary eq 'pass' || $depend->current_result->summary eq 'warn') {
       # There should be a package that we can use to install the port.
-      install_package($depend) || last;
+      install_package($depend, $chroot) || last;
       next;
     }
     
@@ -59,7 +93,7 @@
     $result->add_to_subresults({
       type   => 'prebuild',
       name   => 'SchedulerFailure',
-      msg    => 'Port was schedualed as ready to build, but a dependancy had not been built successfuly.'
+      msg    => 'Port was scheduled as ready to build, but a dependancy had not been built successfuly.'
     });
     
     return 0;
@@ -71,31 +105,34 @@
     
       
 sub install_package {
-  #
-  # we just return 1, cause we're just testing the scheduler.
-  #      
-  print "\tinstall_package: @_\n";         
-  return 1;
+  my ($port, $chroot) = @_;
+  
+  my $file = sprintf("%s-%s.%s", $port->pkgname, $port->version, $Magus::Config{'PkgExtension'});
+  my $arch = $Magus::Machine->arch;
+  my $dest = join('/', $chroot->root, $chroot->packages, 'All');
+  
+  system("/usr/bin/scp $Magus::Config{'PkgfilesRoot'}/$arch/$file $dest"); 
 }  
   
+sub upload_package {
+  my ($port, $chroot) = @_;
+
+  my $arch = $Magus::Machine->arch;
+  my $file = sprintf("%s-%s.%s", $port->pkgname, $port->version, $Magus::Config{'PkgExtension'});
+  my $from = join('/', $chroot->root, $chroot->packages, 'All', $file);
+          
+  system("/usr/bin/scp $from $Magus::Config{'PkgfilesRoot'}/$arch/$file");
+}  
 
+  
 sub run_test {
   my ($lock) = @_;
   
-  sleep(2);
-
-  $lock->port->add_to_results({
-   version => $lock->port->version,
-   machine => $Magus::Machine,
-   summary => 'pass',
-   arch    => $Magus::Machine->arch,
-  });
-}
-  
-sub real_run_test {
-  my ($port) = @_;
+  my $port = $lock->port;
   
-  my $chroot = Magus::Chroot->new(tarball => $Magus::Config{chroot_tarball});
+  my $chroot = Magus::Chroot->new(tarball => $Magus::Config{ChrootTarBall});
+
+  install_depends($lock, $chroot);
   
   # we fork so just the child chroots, then we can get out of the chroot.
   my $pid = fork();
@@ -110,13 +147,21 @@
     my $test    = Magus::PortTest->new(port => $port, chroot => $chroot);
     my $results = $test->run;
   
-    insert_results($results);
+    insert_results($port, $results);
+    
+    exit(0);
   } else {
     die "Could not fork: $!\n";
   } 
 
   # Back to the parent here. 
   if ($? == 0) {
+    my $result = $port->current_result;
+
+    if ($result->summary eq 'pass' || $result->summary eq 'warn') {
+      upload_package($port, $chroot);
+    }
+
     return 1;
   } else {
     die "Child exited unexpectantly: $?\n";
@@ -124,7 +169,31 @@
 }
 
 
-
+sub insert_results {
+  my ($port, $results) = @_;
+  
+  my $res = $port->add_to_results({
+    version => $port->version,
+    summary => $results->{'summary'},
+    machine => $Magus::Machine,
+    arch    => $Magus::Machine->arch,
+  });
+  
+  foreach my $sr (@{$results->{'warnings'}}) {
+    $res->add_to_subresults({
+      type => 'warning',
+      %$sr
+    });
+  }
+  
+  foreach my $sr (@{$results->{'errors'}}) {
+    $res->add_to_subresults({
+      type => 'error',
+      %$sr
+    });
+  }
+}
+      
 
 1;
 __END__