Rewrite in OOP

3 files changed, 434 insertions, 274 deletions

diff --git a/lib/SlackBuild/URI.pm b/lib/SlackBuild/URI.pm
index c286b3f..feac355 100644
--- a/lib/SlackBuild/URI.pm
+++ b/lib/SlackBuild/URI.pm
@@ -32,8 +32,10 @@ sub download {
     print "downloading $self to $dst\n";
     my $ua = LWP::UserAgent->new();
     my $response = $ua->get($self->as_string, ':content_file' => $dst);
-    if (!$response->is_success) {
-	croak "failed to download $self: ".$response->status_line;
+    if (wantarray) {
+	return ($response->is_success, $response->status_line);
+    } else {
+	return $response->is_success;
     }
 }
 
diff --git a/lib/SlackBuilder.pm b/lib/SlackBuilder.pm
new file mode 100644
index 0000000..76c9776
--- /dev/null
+++ b/lib/SlackBuilder.pm
@@ -0,0 +1,414 @@
+package SlackBuilder;
+use strict;
+use warnings;
+use Carp;
+use SlackBuild::URI;
+use File::Basename;
+use File::Temp qw/ tempfile tempdir /;
+use File::Copy;
+use POSIX::Run::Capture qw(:all);
+use POSIX qw(:sys_wait_h strerror);
+
+use constant {
+    E_OK => 0,
+    E_SYNTAX => 1,
+    E_EXEC => 2,
+    E_BADBUILD => 3,
+    E_FAIL => 4
+};
+
+our @EXPORT = qw(E_OK
+                 E_SYNTAX
+                 E_EXEC
+                 E_BADBUILD
+                 E_FAIL);
+
+our $rootdir = "/srv/slackbuild";
+our $image = "slackware:cleanup";
+
+sub new {
+    my ($class, %args) = @_;
+    my $self = bless {}, $class;
+
+    $self->{_rootdir} = delete $args{rootdir} || $rootdir;
+    $self->{_spooldir} = delete $args{spooldir} || "$rootdir/spool";
+    $self->{_tmpdir} = delete $args{tmpdir} || "$rootdir/tmp";
+    $self->{_logdir} = delete $args{logdir} || "$rootdir/log";
+    $self->{_image} = delete $args{image} || $image;
+    $self->{_verbose} = delete $args{verbose};
+
+    croak "bad number of arguments" if keys(%args);
+    
+    $self->clear;
+    
+    return $self;
+}
+
+sub rootdir  { shift->{_rootdir} };
+sub spooldir { shift->{_spooldir} };
+sub tmpdir   { shift->{_tmpdir} };
+sub logdir   { shift->{_logdir} };
+sub image    { shift->{_image} };
+sub verbose  { shift->{_verbose} };
+
+sub error {
+    my ($self, $diag) = @_;
+    push @{$self->{_error}}, $diag;
+}
+
+sub errors {
+    my $self = shift;
+    if (wantarray) {
+	( @{$self->{_error}} );
+    } else {
+	@{$self->{_error}};
+    }
+}
+
+sub errno {
+    my $self = shift;
+    croak "bad number of arguments" if @_ > 1;
+    if (my $v = shift) {
+	$self->{_errno} = $v;
+    }
+    return $self->{_errno};
+}
+
+sub is_success {
+    shift->errno == E_OK;
+}
+
+sub clear {
+    my $self = shift;
+    $self->{_errno} = E_OK;
+    $self->{_error} = [];
+    delete $self->{_request};
+    delete $self->{_result};
+}
+
+my %kws = (
+    package => {
+	mandatory => 1,
+	set => sub {
+	    my ($self, $v) = @_;
+	    $self->package_name($v);
+	}
+    },
+    version => {
+	mandatory => 1,
+	set => sub {
+	    my ($self, $v) = @_;
+	    $self->package_version($v);
+	}
+    },
+    slackbuild_uri => {
+	mandatory => 1,
+	set => sub {
+	    my ($self, $v) = @_;
+	    $self->slackbuild_uri(new SlackBuild::URI($v));
+	}
+    },
+    source_uri => {
+	mandatory => 1,
+	set => sub {
+	    my ($self, $v) = @_;
+	    $self->source_uri(new SlackBuild::URI($v));
+	}
+    },
+    source_archive_name => {
+	mandatory => 0,
+	set => sub {
+	    my ($self, $v) = @_;
+	    $self->source_archive_name($v);
+	}
+    },
+    prereq => {
+	mandatory => 0,
+	set => sub {
+	    my ($self, $v) = @_;
+	    if (ref($v) ne 'ARRAY') {
+		$self->error("prereq: bad data type");
+	    } else {
+		$self->prereq($v);
+	    }
+	}
+    }   
+);
+
+my @ATTRIBUTES = qw(package_name package_version slackbuild_uri source_uri prereq);
+{
+    no strict 'refs';
+    use feature 'state';
+    foreach my $attr (@ATTRIBUTES) {
+	*{ __PACKAGE__ . '::' . $attr } = sub {
+	    my $self = shift;
+	    croak "too many arguments" if @_ > 1;
+	    if (my $v = shift) {
+		$self->{_request}{$attr} = $v;
+	    }
+	    return $self->{_request}{$attr};
+	}
+    }
+}
+
+sub file {
+    my ($self, $name) = @_;
+    push @{$self->{_result}{output_files}}, $name;
+}
+
+sub output_files {
+    my $self = shift;
+    if (wantarray) {
+	return () if $self->errno;
+	return (@{$self->{_result}{output_files}});
+    } else {
+	return @{$self->{_result}{output_files}};
+    }
+}
+
+sub wd {
+    my $self = shift;
+    unless ($self->{_request}{dir}) {
+	$self->{_request}{dir} = tempdir(DIR => $self->spooldir, CLEANUP => 1);
+    }
+    return $self->{_request}{dir};
+}
+
+sub slackbuild_name {
+    my $self = shift;
+    return $self->package_name . '.SlackBuild';
+}
+
+sub source_archive_name {
+    my $self = shift;
+    croak "too many arguments" if @_ > 1;
+    if (my $v = shift) {
+	$self->{_request}{source_archive_name} = $v;
+    }
+    my $res;
+    if (exists($self->{_request}{source_archive_name})) {
+	$res = $self->{_request}{source_archive_name};
+    } else {
+	$res = basename($self->source_uri->path);
+    }
+    return $self->wd . '/' . $res;
+}	
+    
+sub _check_build {
+    my $self = shift;
+    my $obj = $self->_run_tar('-t', '-f', $self->slackbuild_name)
+	or return;
+    my $name = $self->package_name;
+    my $rx = qr($name);
+    my $prefix;
+    my %files;
+    while (my $s = $obj->next_line(SD_STDOUT)) {
+	chomp($s);
+	$s =~ s{^\./}{};
+	if ($s =~ m{^\./}) {
+	    $self->error($self->slackbuild_uri .": bad file: $s");
+	}
+	if ($s =~ s{^$rx/}{}) {
+	    if (defined($prefix)) {
+		if (!$prefix) {
+		    $self->error($self->slackbuild_uri .": bad file: $s");
+		}
+	    } else {
+		$prefix = 1;
+	    }
+	} else {
+	    if (defined($prefix)) {
+		if ($prefix) {
+		    $self->error($self->slackbuild_uri .": bad file: $s");
+		}
+	    } else {
+		$prefix = 0;
+	    }
+	}
+	$files{$s} = 1;
+    }
+
+    if ($self->errors) {
+	$self->errno(E_BADBUILD);
+	return;
+    }
+    
+    $self->error($self->slackbuild_uri
+		 . ": no " . $self->slackbuild_name . " in archive")
+	unless exists $files{$self->slackbuild_name};
+    $self->error($self->slackbuild_uri .
+		 ": no slack-desc in archive")
+	unless exists $files{'slack-desc'};
+
+    if ($self->errors) {
+	$self->errno(E_BADBUILD);
+	return;
+    }
+    
+    return $prefix;
+}
+
+sub run {
+    my $self = shift;
+    my %args;
+    if (@_ == 1) {
+	my $var = shift;
+	%args = %{$var};
+    } else {
+	%args = @_;
+    }
+
+    $self->clear;
+    while (my ($k,$d) = each %kws) {
+	my $v = delete $args{$k};
+	if (defined($v)) {
+	    $self->${\ $d->{set}}($v);
+	} elsif ($d->{mandatory}) {
+	    $self->error("$k: not present");
+	}
+    }
+
+    foreach my $k (keys %args) {
+	$self->error("$k: unknown parameter");
+    }
+    
+    if ($self->errors) {
+	return $self->errno(E_SYNTAX);
+    }
+
+    my ($ok, $errstr) =
+	$self->slackbuild_uri->download($self->slackbuild_name);
+    unless ($ok) {
+	$self->error("can't download "
+		     . $self->slackbuild_name
+		     . ": $errstr");
+	return $self->errno(E_FAIL);
+    }
+
+    my $prefix = $self->_check_build;
+    return $self->errno unless defined($prefix);
+
+    $self->_run_tar('-C', $self->wd,
+		    '--strip', $prefix,
+		    '-x',
+		    '-f',
+		    $self->slackbuild_name)
+	or return $self->errno;
+
+    ($ok, $errstr) = $self->source_uri->download($self->source_archive_name);
+    unless ($ok) {
+	$self->error("can't download "
+		     . $self->source_archive_name
+		     . ": $errstr");
+	return $self->errno(E_FAIL);
+    }
+	
+    return $self->_build;
+}  
+
+sub _runcap_diag {
+    my ($self, $obj) = @_;
+    if (WIFEXITED($obj->status)) {
+	return if $obj->status == 0;
+	while (my $s = $obj->next_line(SD_STDERR)) {
+	    chomp($s);
+	    $self->error($s);
+	}
+	$self->error("program "
+		     . $obj->program
+		     . " terminated with code "
+		     . WEXITSTATUS($obj->status));
+    } elsif (WIFSIGNALED($obj->status)) {
+	$self->error("program "
+		     . $obj->program
+		     . " terminated on signal "
+		     . WTERMSIG($obj->status));
+    } else {
+	$self->error("program "
+		     . $obj->program
+		     . " terminated with unrecogized code "
+		     . $obj->status);
+    }
+    $self->errno(E_EXEC);
+}
+
+sub _run_tar {
+    my $self = shift;
+    
+    return if $self->errno;
+
+    my $obj = new POSIX::Run::Capture(argv => [ 'tar', @_ ],
+				      timeout => 10);
+    if ($obj->run) {
+	$self->_runcap_diag($obj);
+    } else {
+	$self->error("can't run tar: ".strerror($obj->errno));
+	$self->errno(E_EXEC);
+    }
+    return if $self->errno;
+    return $obj;
+}
+
+sub _logfilename {
+    my $self = shift;
+    return $self->logdir . '/' . $self->package_name . '.log';
+}
+
+sub _build {
+    my $self = shift;
+    return $self->errno if $self->errno;
+    my $contname = $self->package_name . '_slackbuild';
+    my @args = ( 'docker',
+		 'run',
+		 '--rm=true',
+		 '--workdir=/usr/src',
+		 '-v', $self->wd . ':/usr/src',
+		 '-v', $self->tmpdir . ':/tmp',
+		 $self->image,
+		 '/bin/sh',
+		 $self->slackbuild_name );
+
+    print "building ".$self->package_name."\n";
+
+    open(my $logfd, '>', $self->_logfilename)
+	or do {
+	    $self->error("can't create log file " .
+			 $self->_logfilename .
+			 ": $!");
+	    return $self->errno(E_FAIL);
+    };
+    
+    my $obj = new POSIX::Run::Capture(argv => \@args,
+				      stdout => sub {
+					  print $logfd 'OUT: ' . shift
+				      },
+				      stderr => sub {
+					  my $line = shift;
+					  chomp($line);
+					  $self->error($line);
+					  if ($self->verbose) {
+					      print STDERR "$line\n";
+					  }
+					  print $logfd "ERR: $line\n";
+				      });
+    $self->{_result}{docker} = $obj;
+    if ($obj->run) {
+	$self->_runcap_diag($obj);
+    } else {
+	$self->error("can't run docker: ".strerror($obj->errno));
+	return $self->errno(E_EXEC);
+    }
+#    $self->errno(E_FAIL) if $self->errors;
+
+    $obj->rewind(SD_STDOUT);
+    while (my $s = $obj->next_line(SD_STDOUT)) {
+	chomp($s);
+	if ($s =~ m{^Slackware package /tmp/(.+?) created}) {
+	    $self->file($1);
+	}
+    }
+    return $self->errno(E_OK);
+}    
+
+
+1;
diff --git a/slackbuilder.pl b/slackbuilder.pl
index 4fefb26..0d1d7ba 100644
--- a/slackbuilder.pl
+++ b/slackbuilder.pl
@@ -6,11 +6,7 @@ use Pod::Usage;
 use Pod::Man;
 use Getopt::Long qw(:config gnu_getopt no_ignore_case);
 use File::Basename;
-use File::Temp qw/ tempfile tempdir /;
-use File::Copy;
-use POSIX::Run::Capture qw(:all);
-use POSIX qw(:sys_wait_h strerror);
-use SlackBuild::URI;
+use SlackBuilder;
 
 use constant {
     EX_OK => 0,
@@ -28,13 +24,6 @@ use constant {
 my $progname = basename($0);
 my $progdescr = "Slackware package builder";
 
-my $rootdir = "/srv/slackbuild";
-my $spooldir = "$rootdir/spool";
-my $tmpdir = "$rootdir/tmp";
-my $logdir = "$rootdir/log";
-
-my $base_image = "slackware:cleanup";
-
 sub abend {
     my $code = shift;
     print STDERR "$progname: " if defined($progname);
@@ -50,32 +39,6 @@ sub error {
             print STDERR "$msg\n"
 }
 
-sub rundiag {
-    my $obj = shift;
-    if (WIFEXITED($obj->status)) {
-	return if $obj->status == 0;
-	while (my $s = $obj->next_line(SD_STDERR)) {
-	    chomp($s);
-	    error($s);
-	}
-	error("program "
-	      . $obj->program
-	      . " terminated with code "
-	      . WEXITSTATUS($obj->status));
-    } elsif (WIFSIGNALED($obj->status)) {
-	error("program "
-	      . $obj->program
-	      . " terminated on signal "
-	      . WTERMSIG($obj->status));
-    } else {
-	print "program "
-	    . $obj->program
-	    . " terminated with unrecogized code "
-	    . $obj->status;
-    }
-    exit(EX_FAIL);
-}
-
 sub readfile {
     my $file = shift;
     local $/ = undef;
@@ -84,232 +47,8 @@ sub readfile {
     close $fd;
     return $string;
 }
-
-my %kws = (
-    package => { mandatory => 1 },
-    version => { mandatory => 1 },
-    archive => { mandatory => 1, check => \&check_slackbuild_url },
-    url => { mandatory => 1, check => \&check_source_url },
-    prereq => {
-	mandatory => 0,
-	check => sub {
-	    my ($json, $key, $err) = @_;
-	    unless (ref($json->{$key}) eq 'ARRAY') {
-		push @{$err}, "wrong type";
-		return 0;
-	    }
-	    return 1;
-	}
-    },
-    source_archive => { mandatory => 0 }
-);
-
-sub check_json {
-    my $json = shift;
-
-    my @err;
-    while (my ($k,$v) = each %{$json}) {
-	unless (exists($kws{$k})) {
-	    push @err, "$k: unknown keyword";
-	    next;
-	}
-	if (exists($kws{$k}{check})) {
-	    &{$kws{$k}{check}}($json, $k, \@err);
-	}
-    }
-    while (my ($k,$v) = each %kws) {
-	if ($v->{mandatory} && !exists($json->{$k})) {
-	    push @err, "$k: not present";
-	}
-    }
-    if (@err) {
-	error("errors in the input file:");
-	foreach my $e (@err) {
-	    error($e);
-	}
-	exit(EX_FAIL);
-    }
-}
-
-	
-sub run_tar {
-    my $obj = new POSIX::Run::Capture(argv => [ 'tar', @_ ],
-				      timeout => 10);
-    if ($obj->run) {
-	rundiag($obj);
-    } else {
-	abend(EX_FAIL, "can't run tar: ".strerror($obj->errno));
-    }
-    return $obj;
-}
-
-sub run_build {
-    my $json = shift;
-    my $contname = $json->{package} . '_slackbuild';
-    my @args = ( 'docker',
-		 'run',
-		 '--rm=true',
-		 '--workdir=/usr/src',
-		 '-v', $json->{workspace}{dir} . ':/usr/src',
-		 '-v', "$tmpdir:/tmp",
-		 $base_image,
-		 '/bin/sh',
-		 $json->{workspace}{slackbuild} );
-
-    my $outfile = "$logdir/$json->{package}.out";
-    my $errfile = "$logdir/$json->{package}.err";
-    open(my $outlog, '>', $outfile)
-	or abend(EX_FAIL, "can't create log file $outfile: $!");
-    open(my $errlog, '>', $errfile)
-	or abend(EX_FAIL, "can't create log file $errfile: $!");
-    print "building ".$json->{package}."\n";
-    my $obj = new POSIX::Run::Capture(argv => \@args,
-				      stdout => sub { print $outlog shift },
-				      stderr => sub {
-					  my $line = shift;
-					  print $errlog $line;
-					  chomp($line);
-					  error($line);
-				      });
-    if ($obj->run) {
-	rundiag($obj);
-    } else {
-	abend(EX_FAIL, "can't run docker: ".strerror($obj->errno));
-    }
-
-    my @files;
-    $obj->rewind(SD_STDOUT);
-    while (my $s = $obj->next_line(SD_STDOUT)) {
-	chomp($s);
-	if ($s =~ m{^Slackware package /tmp/(.+?) created}) {
-	    push @files, $1;
-	}
-    }
-    
-    foreach my $f (@files) {
-	print "$f\n";
-    }
-}    
-
-sub source_archive_name {
-    my $json = shift;
-    my $dst;
-    if (exists($json->{source_archive})) {
-	$dst = $json->{source_archive};
-    } else {
-	$dst = $json->{workspace}{source_uri}->path;
-	$dst =~ s{^.*/}{};
-    }
-    return $json->{workspace}{dir} . '/' . $dst;
-}
-
-sub slackbuild_name {
-    my $json = shift;
-    my $dst;
-    if (exists($json->{slackbuild_archive})) {
-	$dst = $json->{slackbuild_archive};
-    } else {
-	my (undef,undef,$suffix) =
-	    fileparse($json->{workspace}{slackbuild_uri}->path,
-		      '.tar', '.tar.gz', '.tar.xz');
-	$dst = $json->{package} . ($suffix||'');
-    }
-    return $json->{workspace}{dir} . '/' . $dst;
-}
-
-sub download {
-    my ($uri, $dst) = @_;
-
-    my $ua = LWP::UserAgent->new();
-    
-    print "downloading $uri to $dst\n";
-    my $response = $ua->get($uri->as_string, ':content_file' => $dst);
-    if (!$response->is_success) {
-	abend(EX_FAIL,
-	      "downloading $uri failed: ".$response->status_line);
-    }
-}
-
-
-sub check_source_url {
-    my ($json, $key, $err) = @_;
-    my $uri = new SlackBuild::URI($json->{$key});
-    $json->{workspace}{source_uri} = $uri;
-    return 1;
-}
-
-sub check_slackbuild_url {
-    my ($json, $key, $err) = @_;
-    my $uri = new SlackBuild::URI($json->{$key});
-    $json->{workspace}{slackbuild_uri} = $uri;
-    return 1;
-}
-
-sub has_file {
-    my ($json, $file) = @_;
-    grep { $_ eq $file } @{$json->{workspace}{files}}
-}
-
-sub check_archive {
-    my $json = shift;
-    my $obj = run_tar('-t', '-f', slackbuild_name($json));
-    my $err;
-    my $rx = qr($json->{package});
-    my $prefix;
-    while (my $s = $obj->next_line(SD_STDOUT)) {
-	chomp($s);
-	$s =~ s{^\./}{};
-	if ($s =~ m{^\./}) {
-	    error("bad file: $s");
-	    $err = 1;
-	}
-	if ($s =~ s{^$rx/}{}) {
-	    if (defined($prefix)) {
-		if (!$prefix) {
-		    error("bad file: $s");
-		    $err = 1;
-		}
-	    } else {
-		$prefix = 1;
-	    }
-	} else {
-	    if (defined($prefix)) {
-		if ($prefix) {
-		    error("bad file: $s");
-		    $err = 1;
-		}
-	    } else {
-		$prefix = 0;
-	    }
-	}
-		
-	push @{$json->{workspace}{files}}, $s;
-    }
-    exit(EX_FAIL) if $err;
-    $json->{workspace}{slackbuild} = $json->{package} . '.SlackBuild';
-    abend(EX_FAIL, "no ". $json->{workspace}{slackbuild} . " in archive")
-	unless has_file($json, $json->{workspace}{slackbuild});
-    abend(EX_FAIL, "no slack-desc in archive")
-	unless has_file($json, 'slack-desc');
-    return $prefix;
-}
-
-sub makedir {
-    my $json = shift;
-    my $dir = tempdir(DIR => $spooldir, CLEANUP => 1);
-    $json->{workspace}{dir} = $dir;    
-    $json->{workspace}{slackbuild_uri}->download(slackbuild_name($json));
-    
-    my $prefix = check_archive($json);
-    
-    my $obj = run_tar('-C', $dir,
-		      '--strip', $prefix,
-		      '-x',
-		      '-f',
-		      slackbuild_name($json));
-}
-
 
+my $verbose;
 GetOptions("h" => sub {
                pod2usage(-message => "$progname: $progdescr",
 			 -exitstatus => EX_OK);
@@ -320,18 +59,23 @@ GetOptions("h" => sub {
 	   "usage" => sub {
 	       pod2usage(-exitstatus => EX_OK, -verbose => 0);
 	   },
+	   "verbose|v" => \$verbose
     ) or exit(EX_USAGE);
 
 abend(EX_USAGE, "bad number of arguments") unless @ARGV == 1;
 
 my $text = readfile($ARGV[0]);
-my $json = decode_json($text);
-
-check_json($json);
 
-makedir($json);
-
-$json->{workspace}{source_uri}->download(source_archive_name($json));
-
-# FIXME: Prerequisites
-run_build($json);
+my $builder = new SlackBuilder(verbose => $verbose);
+$builder->run(decode_json($text));
+if ($builder->is_success) {
+    print "OK. File list:\n";
+    foreach my $f ($builder->output_files) {
+	print "$f\n";
+    }
+} else {
+    print STDERR "ERROR: " . $builder->errno . "\n";
+    foreach my $e ($builder->errors) {
+	print STDERR "$e\n";
+    }
+}