[Midnightbsd-cvs] CVS Commit: lib/Mport: Start of the perl libraries for playing with

[ctriv at midnightbsd.org]

Log Message:
-----------
Start of the perl libraries for playing with mports.  At the moment this
commit is simply to backup my work so far.  The code is not yet usable.  As
perl will be the official language for major scripting in the mports system,
these libraries will - over time - become quite extensive.

Added Files:
-----------
    mports/Tools/lib/Mport:
        Globals.pm (r1.1)
        Index.pm (r1.1)
        Port.pm (r1.1)
        Smoke.pm (r1.1)
        Utils.pm (r1.1)

-------------- next part --------------
--- /dev/null
+++ Tools/lib/Mport/Smoke.pm
@@ -0,0 +1,78 @@
+package Mport::Smoke;
+#
+# $MidnightBSD: mports/Tools/lib/Mport/Smoke.pm,v 1.1 2007/08/15 20:55:39 ctriv Exp $
+#
+
+use strict;
+use warnings;
+use File::Temp qw(tmpdir);
+use YAML;
+use DBI;
+
+sub new {
+  my ($class, $config) = @_;
+  
+  my $self = {};
+  
+  $self->{config} = Load($config);
+
+  bless($self, $class);
+
+  $self->_connect_db();
+  
+  return $self;
+}
+
+#
+# $smoke->test($port)
+#
+# Test a single port.  This function will return non-sensical results 
+# if you have't already tested the dependencies.
+#
+sub test {
+  my ($self, $port) = @_;
+  
+  my $root = $self->_setup_chroot();
+  
+  # we fork so just the child chroot's, then we can get out of the chroot.
+  my $pid = fork();
+  if ($pid) {
+    # Parent, we wait for the child to finish.
+    waitpid($pid);
+  } elsif (defined $pid) {
+    # Child, chroot and go.
+    chroot($root);
+    chdir($port->abs_orig);
+  
+    my $res = `$MAKE install 2>&1`;
+  
+    $self->_store_results($port, $?, $res);
+    exit(0);
+  } else {
+    die "Could not fork: $!\n";
+  } 
+}
+
+
+sub _setup_chroot {
+  my ($self) = @_;
+  my $root = tmpdir();
+  
+  system(qw(/usr/bin/tar xfz $self->{config}->{chroot_tarball} -C $root)) == 0 
+    or die "Couldn't untar root tarball: $?\n";
+   
+  return $root;
+}
+
+
+sub _connect_db {
+  my ($self) = @_;
+  
+  $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{config}->{dbfile}", "", "", 
+    { RaiseError => 1, PrintError => 0 }
+  );
+} 
+
+1;
+__END__
+
--- /dev/null
+++ Tools/lib/Mport/Port.pm
@@ -0,0 +1,89 @@
+package Mport::Port;
+#
+# $MidnightBSD: mports/Tools/lib/Mport/Port.pm,v 1.1 2007/08/15 20:55:39 ctriv Exp $
+#
+use strict;
+use warnings;
+use Cwd;
+use Fatal qw(chdir);
+use Text::ParseWords qw(shellwords);
+
+use Mport::Index;
+use Mport::Globals qw($MAKE);
+
+=head2 Mport::Port->new()
+
+Create a Mport::Port object.  If given a hashref as an argument, this method
+is a simple constructor.  If given a string, then an attempt is made to find 
+port in the index.
+
+=cut
+
+sub new {
+  my $class = shift;
+  
+  if (ref $_[0] && ref $_[0] eq 'HASH') {
+    return $class->_new_from_hash($_[0]);
+  } else {
+    return Mport::Index->find_port($_[0]);
+  }
+}
+
+sub name   { return $_[0]->{'name'}   }
+sub origin { return $_[0]->{'origin'} } 
+
+sub make {
+  my $self = shift;
+  
+  $self->_to_orig;
+  system($MAKE, @_);  
+  $self->_leave_orig;
+}
+
+sub _to_orig {
+  my ($self) = @_;
+  
+  $self->{'_cwd'} = getcwd();
+  
+  chdir($self->origin);
+}
+
+sub _leave_orig {
+  my ($self) = @_;
+  
+  chdir($self->{'_cwd'});
+}
+
+sub options {
+  my ($self) = @_;
+ 
+  unless ($self->{'options'}) {
+ 
+    my @opts = shellwords($self->_make_var('OPTIONS'));
+    $self->{'options'} = {};
+ 
+    while (@opts) {
+      my $var = shift @opts;
+      shift @opts;  # var description
+      my $value = shift @opts;
+      $self->{'options'}->{$var} = $value eq 'On' ? 1 : 0;
+    }
+  }
+  
+  return $self->{'options'};
+}
+
+sub _make_var {
+  my ($self, @vars) = @_;
+  
+  my $args = join(' ', map { "-V $_" } @vars);
+  
+  $self->_to_orig;
+  my @ret = `$MAKE $args`;
+  $self->_leave_orig;
+
+  return wantarray ? @ret : join("\n", @ret);
+}
+
+1;
+__END__
--- /dev/null
+++ Tools/lib/Mport/Globals.pm
@@ -0,0 +1,20 @@
+package Mport::Globals;
+#
+# $MidnightBSD: mports/Tools/lib/Mport/Globals.pm,v 1.1 2007/08/15 20:55:39 ctriv Exp $
+#
+
+
+use strict;
+use warnings;
+use Exporter ();
+
+*import = \&Exporter::import;
+
+our @EXPORT = qw($ROOT $INDEX $MAKE);
+
+our $MAKE  = '/usr/bin/make';
+our $ROOT  = '/usr/mports';
+our $INDEX = "$ROOT/INDEX.db";
+
+1;
+__END__
--- /dev/null
+++ Tools/lib/Mport/Utils.pm
@@ -0,0 +1,29 @@
+package Mport::Utils;
+#
+# $MidnightBSD: mports/Tools/lib/Mport/Utils.pm,v 1.1 2007/08/15 20:55:39 ctriv Exp $
+#
+use strict;
+use warnings;
+use Exporter ();
+use Text::ParseWords qw(shellwords);
+use Mport::Globals qw($MAKE);
+
+*import = \&Exporter::import;
+
+our @EXPORT = qw(make_var);
+
+sub make_var {
+  my $vars  = join(' ', map { "-V $_" } @_);
+  my $ret   = `$MAKE $vars`;
+  
+  if (wantarray) {
+    return shellwords($ret);
+  } else {
+    return $ret;
+  }
+}
+  
+
+
+1;
+__END__
--- /dev/null
+++ Tools/lib/Mport/Index.pm
@@ -0,0 +1,116 @@
+package Mport::Index;
+#
+# $MidnightBSD: mports/Tools/lib/Mport/Index.pm,v 1.1 2007/08/15 20:55:39 ctriv Exp $
+#
+use strict;
+use warnings;
+
+use Mport::Globals qw($ROOT $INDEX);
+use Mport::Port ();
+use Mport::Utils qw(make_var);
+use YAML;
+
+use Cwd;
+use Fatal qw(chdir);
+use DBI;
+
+sub build {
+  my ($class) = @_;
+  
+  my $cwd = $ROOT;
+  my $dbh = create_db();
+      
+  chdir($cwd);
+
+  recurse($cwd, $dbh);
+}
+
+sub recurse {  
+  my ($cwd, $dbh) = @_;
+  
+  my @subdirs = make_var('SUBDIR');
+  
+  if (!@subdirs) {
+    return process_port($cwd, $dbh);
+  }
+  
+  foreach my $subdir (@subdirs) {
+    $subdir = "$cwd/$subdir";
+    eval { chdir($subdir); };
+    next if $@;
+    recurse($subdir, $dbh)
+  }   
+}
+
+sub process_port {
+  my ($cwd, $dbh) = @_;
+  
+  my $yaml = `make describe-yaml`;
+  my %port;
+  eval {
+    %port = %{Load($yaml)};  
+  };
+  
+  if ($@) {
+    warn "Unable to parse yaml for $cwd\n";
+    return;
+  }
+
+  local $dbh->{AutoCommit} = 0;
+  
+  eval {
+    my $sth = $dbh->prepare("INSERT INTO mports (name, version, description, origin) VALUES (?,?,?,?)");
+    $sth->execute(@port{qw(name version description origin)});
+    $sth->finish;
+  
+    $sth = $dbh->prepare("INSERT INTO depends (port, type, dependency) VALUES (?,?,?)");
+    foreach my $type (qw(lib run build patch extract fetch)) {
+      foreach my $dep (@{$port{"${type}_depends"}}) {
+        $sth->execute($port{'name'}, $type, $dep);
+      }
+    }
+    $sth->finish;
+    
+    $dbh->commit;
+  };
+  
+  if ($@) {
+    warn "Unable to insert $port{'name'}: $@\n";
+    eval { $dbh->rollback };
+  }    
+}
+
+sub create_db {
+  unlink($INDEX);
+  my $dbh = DBI->connect("dbi:SQLite:dbname=$INDEX", "", "", { RaiseError => 1, PrintError => 0 });
+  $dbh->do(<<END_O_SQL);
+CREATE TABLE mports (
+  name text primary key,
+  version text,
+  description text,
+  origin text
+)
+END_O_SQL
+  $dbh->do(<<END_O_SQL);
+CREATE TABLE depends (
+  port text, 
+  type text,
+  dependency text
+);
+END_O_SQL
+  $dbh->do('CREATE INDEX mport_version_index ON mports (name, version)');
+  $dbh->do('CREATE INDEX depends_port ON depends (port)');
+  $dbh->do('CREATE INDEX depends_revese ON depends (dependency)');
+  $dbh->do('CREATE INDEX depends_type ON depends (port, type)');
+  
+  return $dbh;
+}
+  
+  
+  
+  
+
+   
+1;
+__END__
+ 
\ No newline at end of file