diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2017-11-24 19:45:35 +0100 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2017-11-24 20:15:47 +0100 |
commit | 1c5393a6f0498cb395452e521e81d802742db359 (patch) | |
tree | 4bbb1bbc0b451e25d0bbfb89e983f7d7a4e7927c | |
parent | 047e5e111a83ae82b13f0a75e48961c4ce656b40 (diff) | |
download | slackbuilder-1c5393a6f0498cb395452e521e81d802742db359.tar.gz slackbuilder-1c5393a6f0498cb395452e521e81d802742db359.tar.bz2 |
Introduce slackbuild registry. Add testsuite.
* .gitignore: New file.
* lib/SlackBuild/Archive.pm (info): New method.
* lib/SlackBuild/URI.pm (download): Make argument optional.
Default to basename from the path.
* lib/SlackBuilder.pm (%kws): New keyword: build
(run): Fall back to the info{DOWNLOAD}, in case source_uri is
not supplied.
* lib/SlackBuild/Base.pm: New file.
* lib/SlackBuild/Registry.pm: New file.
* lib/SlackBuild/Registry/Backend/FS.pm: New file.
* lib/SlackBuild/Registry/Record.pm: New file.
* lib/SlackBuild/Registry/Version.pm: New file.
* lib/SlackBuild/match.pm: New file.
* t/regrec.t: New file.
* t/vercmp.t: New file.
* t/version.t: New file.
-rw-r--r-- | .gitignore | 7 | ||||
-rw-r--r-- | lib/SlackBuild/Archive.pm | 31 | ||||
-rw-r--r-- | lib/SlackBuild/Archive/Extractor/Tar.pm | 1 | ||||
-rw-r--r-- | lib/SlackBuild/Base.pm | 41 | ||||
-rw-r--r-- | lib/SlackBuild/Registry.pm | 54 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Backend/FS.pm | 123 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Record.pm | 148 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Version.pm | 98 | ||||
-rw-r--r-- | lib/SlackBuild/URI.pm | 5 | ||||
-rw-r--r-- | lib/SlackBuild/match.pm | 65 | ||||
-rw-r--r-- | lib/SlackBuilder.pm | 23 | ||||
-rw-r--r-- | t/regrec.t | 31 | ||||
-rw-r--r-- | t/vercmp.t | 32 | ||||
-rw-r--r-- | t/version.t | 25 |
14 files changed, 679 insertions, 5 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..88b2c09 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +*~ +\#*# +.#* +*.tar* +.emacs.* +/tmp/ +core diff --git a/lib/SlackBuild/Archive.pm b/lib/SlackBuild/Archive.pm index 8167297..6d390c2 100644 --- a/lib/SlackBuild/Archive.pm +++ b/lib/SlackBuild/Archive.pm @@ -46,7 +46,36 @@ sub download { unless ($self->SUPER::download($tmp)) { return $self->error($self->SUPER::download_status); } - return SlackBuild::Archive::Extractor->backend($self, $tmp, $dst)->extract; + unless (SlackBuild::Archive::Extractor->backend($self, $tmp, $dst) + ->extract) { + return 0; + } + $self->_read_info($dst); + return 1; +} + +sub _read_info { + my ($self, $dst) = @_; + my $info = $self->package_name . '.info'; + return unless $self->has_file($info); + open(my $fd, '<', $dst . '/'. $info) + or return; + my %info; + while (<$fd>) { + chomp; + s/^\s+//; + next if /^(#.*)?$/; + return unless /^(?<kw>[A-Za-z_][A-Za-z_0-9]*)="(?<val>.*)"$/; + $info{$+{kw}} = $+{val}; + } + close $fd; + $self->{_info} = \%info; +} + +sub info { + my ($self, $kw) = @_; + return undef unless exists $self->{_info}; + return $self->{_info}{$kw}; } sub download_success { diff --git a/lib/SlackBuild/Archive/Extractor/Tar.pm b/lib/SlackBuild/Archive/Extractor/Tar.pm index b516893..1fcd428 100644 --- a/lib/SlackBuild/Archive/Extractor/Tar.pm +++ b/lib/SlackBuild/Archive/Extractor/Tar.pm @@ -33,7 +33,6 @@ sub _runcap_diag { sub _run_tar { my $self = shift; - my $obj = new POSIX::Run::Capture(argv => [ 'tar', @_ ], timeout => 10); if ($obj->run) { diff --git a/lib/SlackBuild/Base.pm b/lib/SlackBuild/Base.pm new file mode 100644 index 0000000..9710392 --- /dev/null +++ b/lib/SlackBuild/Base.pm @@ -0,0 +1,41 @@ +package SlackBuild::Base; +use strict; +use warnings; +use Carp; +use parent 'Exporter'; +no strict 'refs'; + +sub import { + my $pkg = shift; # package + my ($package, $filename, $line) = caller; + foreach my $dfn (@_) { + if ($dfn =~ m/^(?<attr>[a-zA-Z_][a-zA-Z_0-9]*) + (?::(?<flag>.*))?$/x) { + my $attribute = $+{attr}; + my $flag = $+{flag} || 'rw'; + if ($flag eq 'ro') { + *{ $package . '::' . $attribute } = sub { + my $self = shift; + croak "too many arguments for ${package}::$attribute" + if @_; + return $self->{$attribute}; + } + } else { + *{ $package . '::' . $attribute } = sub { + my $self = shift; + if (@_) { + croak "too many arguments for ${package}::$attribute" + if @_ > 1; + $self->{$attribute} = shift; + } + return $self->{$attribute}; + } + } + } else { + croak "$filename:$line: bad attribute spec: $dfn" + } + } +} + +1; + diff --git a/lib/SlackBuild/Registry.pm b/lib/SlackBuild/Registry.pm new file mode 100644 index 0000000..8bbc7b8 --- /dev/null +++ b/lib/SlackBuild/Registry.pm @@ -0,0 +1,54 @@ +package SlackBuild::Registry; +use strict; +use warnings; +use Carp; +use SlackBuild::Base qw(backend:ro); + +=head1 NAME + +SlackBuild::Registry - registry of completed builds + +=head2 new + + $x = new SlackBuild::Registry(BACKEND, KW=>VAL, ...) + +Creates new registry object. I<BACKEND> is the name of the backend +to use. The class B<SlackBuild::Registry::Backend::I<BACKEND>> must +exist. The arguments (I<KW =E<gt> VAL> pairs) are passed to its +constructor. + +=cut + +sub new { + my $class = shift; + my $backend = shift or croak "no backend specified"; + $backend = "SlackBuild::Registry::Backend::$backend"; + eval "use $backend"; + croak $@ if $@; + my $self = bless {}, $class; + $self->{backend} = $backend->new(@_); + return $self; +} + +=head2 lookup + + @a = $x->lookup(PACKAGE, [version=>X], [arch=>Y], [build=>Z]) + +Returns a sorted array of SlackBuild::Registry::Record objects matching the +search criteria. + +=cut + +sub lookup { + my $self = shift; + my $pkg = shift or croak "nothing to look up"; + local %_ = @_; + return $self->backend->lookup($pkg, %_); +} + +1; + + + + + diff --git a/lib/SlackBuild/Registry/Backend/FS.pm b/lib/SlackBuild/Registry/Backend/FS.pm new file mode 100644 index 0000000..20e5df1 --- /dev/null +++ b/lib/SlackBuild/Registry/Backend/FS.pm @@ -0,0 +1,123 @@ +package SlackBuild::Registry::Backend::FS; +use strict; +use warnings; +use Carp; +use File::Basename; +use List::Regexp; +use File::stat; +use Fcntl ':mode'; +use SlackBuild::Registry::Record; + +=head1 NAME + +SlackBuild::Registry::Backend::FS - filesystem backend for slackbuild registry + +=head1 SYNOPSIS + + $reg = new SlackBuild::Registry(dir => DIRECTORY); + my @a = $x->lookup('openssl', version => '1.0.2m'); + +=head1 METHODS + +=head2 new + + $x = new SlackBuild::Registry::Backend::FS(dir => DIRECTORY) + +=cut + +sub new { + my $class = shift; + my $self = bless {}, $class; + local %_ = @_; + if (my $dir = delete $_{dir}) { + $self->{dir} = $dir; + } else { + croak "required parameter dir not present"; + } + croak "too many arguments" if keys %_; + return $self; +} + +my @architectures = qw(i386 x86_64 arm); +my @suffixes = qw(.tgz .txz); + +=head2 lookup + + @a = $backend->lookup(PACKAGE, [version=>X], [arch=>Y], [build=>Z]) + +Returns a sorted array of SlackBuild::Registry::Record objects matching the +search criteria. + +=cut + +sub lookup { + my ($self, $pkg, %keys) = @_; + my $v; + + my $pat = "$pkg-"; + $pat .= ($keys{version} || '*') . '-'; + $pat .= ($keys{arch} || '*') . '-'; + if ($keys{build}) { + $pat .= $keys{build}; + } + $pat .= '*'; + + my $rx = '^' . qr($pkg) . '-'; + $rx .= '(?<version>'; + if ($keys{version}) { + $rx .= qr($keys{version}); + } else { + $rx .= '\d+(\.\d+)+.*?'; + } + $rx .= ')-(?<arch>'; + if ($keys{arch}) { + $rx .= qr($keys{arch}); + } else { + $rx .= regexp_opt(@architectures); + } + $rx .= ')-(?<build>'; + if ($keys{build}) { + $rx .= qr($keys{build}); + } else { + $rx .= '\d+'; + } + $rx .= ')(?<pfx>.*)$'; + + my @result = sort { + my $d; + if ($d = ($a->package || '') cmp ($b->package || '')) { + $d + } elsif ($d = $b->version <=> $a->version) { + $d + } elsif ($a->arch && $b->arch + && ($d = $a->arch cmp $b->arch)) { + $d + } else { + ($b->build || 1) <=> ($a->build || 1) + } + } map { + my ($name,$path,$suffix) = fileparse($_, @suffixes); + if ($name =~ m{$rx}) { + my $st = stat($_); + if (S_ISREG($st->mode)) { + new SlackBuild::Registry::Record($pkg, + version => $+{version}, + arch => $+{arch}, + build => $+{build}, + date => $st->mtime, + filename => $_) + } else { + () + } + } else { + () + } + } (glob $self->{dir} . '/' . $pat); + if (wantarray) { + (@result) + } else { + shift @result; + } +} + +1; diff --git a/lib/SlackBuild/Registry/Record.pm b/lib/SlackBuild/Registry/Record.pm new file mode 100644 index 0000000..90f6d05 --- /dev/null +++ b/lib/SlackBuild/Registry/Record.pm @@ -0,0 +1,148 @@ +package SlackBuild::Registry::Record; +use strict; +use warnings; +use Carp; +use SlackBuild::Base qw(package arch build date filename); +use SlackBuild::Registry::Version; +use SlackBuild::match; +use Scalar::Util qw(blessed); + +=head2 new + + $x = new SlackBuild::Registry::Record(PACKAGE, + arch=>X, version=>Y, build=>Z, date=>D, filename=>F) + +=cut + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->build(1); + if (my $v = shift) { + $self->package($v); + if (@_) { + croak "bad number of arguments" if (@_ % 2); + local %_ = @_; + while (my ($k,$v) = each %_) { + $self->${\$k}($v); + } + } + } + return $self; +} + +sub version { + my $self = shift; + if (@_) { + croak "too many arguments" if @_ > 1; + $self->{version} = new SlackBuild::Registry::Version(shift); + } + return $self->{version}; +} + +sub store { + my $self = shift; + croak "store not implemented"; +} + +sub as_string { + my $self = shift; + return $self->package . '-' . $self->version . '-' . $self->arch . '-' . + ($self->build || '1'); +} + +sub cmp { + my ($self, $other) = @_; + + my $v; + if ($v = ($self->package || '') cmp ($other->package || '')) { + return $v; + } + if ($self->version <=> $other->version) { + return $v; + } + if ($self->arch && $other->arch + && ($v = $self->arch cmp $other->arch)) { + return $v; + } + return ($self->build || 1) <=> ($other->build || 1); +} + +sub match_attr { + my ($self, $pred) = @_; + my ($meth, $arg); + if (ref($pred) eq 'ARRAY') { + croak "array must have 2 elements" unless @$pred == 2; + ($meth, $arg) = @$pred; + } elsif (ref($pred) eq 'HASH') { + croak "array must have 1 key" unless keys(%$pred) == 1; + ($meth, $arg) = each %$pred; + } else { + return $self == $pred; + } + return match($self->${ \$meth }, $arg); +} + +sub matches { + my $self = shift; + my $args; + if (@_ == 1) { + if (ref($_[0]) eq 'HASH') { + $args = $_[0]; + } else { + croak "bad argument"; + } + } elsif (@_ % 2 == 0) { + local %_ = @_; + $args = \%_; + } else { + croak "odd number of arguments"; + } + while (my ($meth, $pred) = each %$args) { + return 0 unless match($self->${ \$meth }, $pred); + } + return 1; +} + +use overload + '""' => sub { shift->as_string }, + 'cmp' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other); + return $swap ? -$res : $res; + }, + '<=>' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other); + return $swap ? -$res : $res; + }, + '==' => sub { + my ($self, $other) = @_; + my $res = $self->cmp($other) == 0; + }, + '!=' => sub { + my ($self, $other) = @_; + my $res = $self->cmp($other) != 0; + }, + '<' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) < 0; + return $swap ? !$res : $res; + }, + '<=' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) <= 0; + return $swap ? !$res : $res; + }, + '>' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) > 0; + return $swap ? !$res : $res; + }, + '>=' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) >= 0; + return $swap ? !$res : $res; + }; + +1; diff --git a/lib/SlackBuild/Registry/Version.pm b/lib/SlackBuild/Registry/Version.pm new file mode 100644 index 0000000..8a7d051 --- /dev/null +++ b/lib/SlackBuild/Registry/Version.pm @@ -0,0 +1,98 @@ +package SlackBuild::Registry::Version; +use strict; +use warnings; +use Carp; +use SlackBuild::Base qw(major minor patch tail string:ro); + +sub new { + my $class = shift; + my $self = bless {}, $class; + if (my $s = shift) { + croak "too many arguments" if @_; + $self->parse($s); + } + return $self; +} + +sub major_number { shift->major || 0 }; +sub minor_number { shift->minor || 0 }; +sub patch_number { shift->patch || 0 }; +sub tail_string { shift->tail || '' }; + +sub parse { + my ($self, $str) = @_; + + $self->{string} = $str; + delete $self->{major}; + delete $self->{minor}; + delete $self->{patch}; + delete $self->{tail}; + + if ($str =~ s/^(\d+)(.*)/$2/) { + $self->major($1); + if ($str =~ s/^\.(\d+)(.*)/$2/) { + $self->minor($1); + if ($str =~ s/^\.(\d+)(.*)/$2/) { + $self->patch($1); + } + } + } + $self->tail($str); +} + +sub cmp { + my ($self, $other) = @_; + + $other = __PACKAGE__->new($other) unless ref($other); + + foreach my $part (map { "${_}_number" } qw(major minor patch)) { + if (my $d = $self->${\$part} <=> $other->${\$part}) { + return $d; + } + } + return $self->tail_string cmp $other->tail_string; +} + +use overload + '""' => sub { shift->string }, + 'cmp' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other); + return $swap ? -$res : $res; + }, + '<=>' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other); + return $swap ? -$res : $res; + }, + '==' => sub { + my ($self, $other) = @_; + my $res = $self->cmp($other) == 0; + }, + '!=' => sub { + my ($self, $other) = @_; + my $res = $self->cmp($other) != 0; + }, + '<' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) < 0; + return $swap ? !$res : $res; + }, + '<=' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) <= 0; + return $swap ? !$res : $res; + }, + '>' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) > 0; + return $swap ? !$res : $res; + }, + '>=' => sub { + my ($self, $other, $swap) = @_; + my $res = $self->cmp($other) >= 0; + return $swap ? !$res : $res; + }; + + +1; diff --git a/lib/SlackBuild/URI.pm b/lib/SlackBuild/URI.pm index 8556783..bd99321 100644 --- a/lib/SlackBuild/URI.pm +++ b/lib/SlackBuild/URI.pm @@ -4,6 +4,7 @@ use warnings; use URI; use Carp; use LWP::UserAgent; +use File::Basename; # use LWP::Protocol::https; # use LWP::Protocol::file; # use LWP::Protocol::ftp; @@ -51,8 +52,8 @@ sub new_abs { use overload '""' => sub { shift->as_string }; sub download { - croak "bad number of arguments" unless @_ == 2; - my ($self, $dst) = @_; + my $self = shift; + my $dst = shift || basename($self->path); my $scheme = $self->scheme; require "LWP/Protocol/$scheme.pm"; print "downloading $self to $dst\n"; diff --git a/lib/SlackBuild/match.pm b/lib/SlackBuild/match.pm new file mode 100644 index 0000000..9b99d95 --- /dev/null +++ b/lib/SlackBuild/match.pm @@ -0,0 +1,65 @@ +package SlackBuild::match; +use strict; +use warnings; +use parent 'Exporter'; +use Carp; +use Scalar::Util qw(looks_like_number); + +our @EXPORT = qw(match); + +my %matchtab = ( + -eq => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a == $b : $a eq $b; + }, + -ne => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a != $b : $a ne $b; + }, + -lt => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a < $b : $a lt $b; + }, + -le => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a <= $b : $a le $b; + }, + -gt => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a gt $b; + }, + -ge => sub { + my ($a, $b) = @_; + (looks_like_number($a) && looks_like_number($b)) ? $a > $b : $a ge $b; + }, + -in => sub { + my ($a, $b) = @_; + croak 'argument to -in must be array' + unless ref($b) eq 'ARRAY'; + foreach my $v (@$b) { + return 1 + if (looks_like_number($a) && looks_like_number($v)) + ? $a == $v : $a eq $v; + } + } +); + +sub match { + my ($val, $pred) = @_; + + my ($fun, $arg); + if (ref($pred) eq 'ARRAY') { + croak "array must have 2 elements" unless @$pred == 2; + ($fun, $arg) = @$pred; + } elsif (ref($pred) eq 'HASH') { + croak "array must have 1 key" unless keys(%$pred) == 1; + ($fun, $arg) = each %$pred; + } else { + return $val == $pred; + } + + croak "unknown predicate: $fun" + unless (exists($matchtab{$fun})); + + &{$matchtab{$fun}}($val, $arg); +} diff --git a/lib/SlackBuilder.pm b/lib/SlackBuilder.pm index 0b100be..ed0d15a 100644 --- a/lib/SlackBuilder.pm +++ b/lib/SlackBuilder.pm @@ -102,6 +102,13 @@ my %kws = ( $self->package_version($v); } }, + build => { + mandatory => 0, + set => sub { + my ($self, $v) = @_; + $self->package_build($v); + } + }, slackbuild_uri => { mandatory => 1, set => sub { @@ -136,7 +143,12 @@ my %kws = ( } ); -my @ATTRIBUTES = qw(package_name package_version slackbuild_uri source_uri prereq); +my @ATTRIBUTES = qw(package_name + package_version + package_build + slackbuild_uri + source_uri + prereq); { no strict 'refs'; use feature 'state'; @@ -240,6 +252,15 @@ sub run { . $self->source_uri->download_status); return $self->errno(E_FAIL); } + } elsif (my $d = $archive->info('DOWNLOAD')) { + foreach my $s (split /\s+/, $d) { + my $uri = new SlackBuild::URI($s); + my $dest = $self->wd . '/' . basename($uri->path); + unless ($uri->download($dest)) { + $self->error("can't download $uri: ".$uri->download_status); + return $self->errno(E_FAIL); + } + } } return $self->_build; diff --git a/t/regrec.t b/t/regrec.t new file mode 100644 index 0000000..6035c49 --- /dev/null +++ b/t/regrec.t @@ -0,0 +1,31 @@ +# -*- perl -*- +use lib 't'; +use strict; +use warnings; +use SlackBuild::Registry::Record; +use Test; + +plan tests => 6; + +my $r = new SlackBuild::Registry::Record('foo', + arch => 'x86_64', + version => '1.0', + build => 1, + date => 0); + +ok("$r", 'foo-1.0-x86_64-1'); + +my $x = new SlackBuild::Registry::Record('foo', + arch => 'x86_64', + version => '1.0', + build => 2, + date => 0); + +ok($r < $x); +ok($r <=> $x, -1); + +ok($r->matches(version => { -gt => '0.2' })); +ok($r->matches(version => { -gt => '0.2' }, + arch => { -in => [ qw(i386 x86_64)] }) ); +ok(!$r->matches(version => { -gt => '0.2' }, + arch => { -eq => 'i386' })); diff --git a/t/vercmp.t b/t/vercmp.t new file mode 100644 index 0000000..54b1c80 --- /dev/null +++ b/t/vercmp.t @@ -0,0 +1,32 @@ +# -*- perl -*- +use lib 't'; +use strict; +use warnings; +use SlackBuild::Registry::Version; +use Test; + +plan tests => 8; + +ok(SlackBuild::Registry::Version->new('1.0') == + SlackBuild::Registry::Version->new('1.0')); + +ok(SlackBuild::Registry::Version->new('1.0') < + SlackBuild::Registry::Version->new('1.1')); + +ok(SlackBuild::Registry::Version->new('1.0.1') > + SlackBuild::Registry::Version->new('1.0.0')); + +ok(SlackBuild::Registry::Version->new('1.0.1') > + SlackBuild::Registry::Version->new('1.0')); + +ok(SlackBuild::Registry::Version->new('2.1,6') < + SlackBuild::Registry::Version->new('2.2')); + +ok(SlackBuild::Registry::Version->new('1.0_A') < + SlackBuild::Registry::Version->new('1.0_B')); + +ok(SlackBuild::Registry::Version->new('1.3_Z') < + SlackBuild::Registry::Version->new('1.4_A')); + +ok(SlackBuild::Registry::Version->new('1.0') == '1.0'); + diff --git a/t/version.t b/t/version.t new file mode 100644 index 0000000..26c7d3e --- /dev/null +++ b/t/version.t @@ -0,0 +1,25 @@ +# -*- perl -*- +use lib 't'; +use strict; +use warnings; +use SlackBuild::Registry::Version; +use Test; + +plan tests => 10; + +my $v = new SlackBuild::Registry::Version('4'); +ok($v->major, '4'); +ok(!$v->minor); +ok(!$v->patch); + +$v = new SlackBuild::Registry::Version('4.1.9'); +ok($v->major, '4'); +ok($v->minor, '1'); +ok($v->patch, '9'); + +$v = new SlackBuild::Registry::Version('4.1.9m'); +ok($v->major, '4'); +ok($v->minor, '1'); +ok($v->patch, '9'); +ok($v->tail, 'm'); + |