summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2018-06-19 16:36:58 +0200
committerSergey Poznyakoff <gray@gnu.org.ua>2018-06-19 16:52:11 +0200
commit5091d2c21569478bab5eeac0ad1cf6c4e459ab87 (patch)
tree850e286ecdbde28bb70f490975eb9a83b2a61ba9
parent7118ffe16d97b2a589047408ea704133a3aa28ad (diff)
downloadslackbuilder-5091d2c21569478bab5eeac0ad1cf6c4e459ab87.tar.gz
slackbuilder-5091d2c21569478bab5eeac0ad1cf6c4e459ab87.tar.bz2
Introduce SBo URIs
* lib/Net/SBo.pm: New file. Slackbuilds.org repository access. * lib/URI/sbo.pm: New file. sbo:// URIs * lib/LWP/Protocol/sbo.pm: New file. LWP protocol handler for sbo:// URIs * lib/SlackBuild/Registry/Backend/FS.pm: Scan the directory before returning from the constructor. The lookup method uses cached data. This allows to speed-up multiple look-ups. * slackbuilder: If argument is neither an existing file nor https? URI, treat it as a slackbuild package name
-rw-r--r--lib/LWP/Protocol/sbo.pm61
-rw-r--r--lib/Net/SBo.pm289
-rw-r--r--lib/SlackBuild/Registry/Backend/FS.pm66
-rw-r--r--lib/URI/sbo.pm37
-rwxr-xr-xslackbuilder24
5 files changed, 449 insertions, 28 deletions
diff --git a/lib/LWP/Protocol/sbo.pm b/lib/LWP/Protocol/sbo.pm
new file mode 100644
index 0000000..676a326
--- /dev/null
+++ b/lib/LWP/Protocol/sbo.pm
@@ -0,0 +1,61 @@
1package LWP::Protocol::sbo;
2use base qw(LWP::Protocol);
3use strict;
4use warnings;
5use File::Temp;
6
7our $VERSION = '1.00';
8
9use HTTP::Request;
10use HTTP::Response;
11use HTTP::Status;
12
13sub request {
14 my ($self, $request, $proxy, $arg, $size) = @_;
15
16 if (defined $proxy) {
17 return HTTP::Response->new(HTTP::Status::RC_BAD_REQUEST,
18 'You can not proxy through the SBo archive');
19 }
20
21 unless ($request->method eq 'GET') {
22 return HTTP::Response->new(HTTP::Status::HTTP_METHOD_NOT_ALLOWED,
23 "Only GET is allowed for sbo: URLs");
24 }
25
26 my $url = $request->uri;
27 my $scheme = $url;
28 if ($url->scheme ne 'sbo') {
29 return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR,
30 __PACKAGE__."::request called for '$scheme'");
31 }
32
33 my $fh = new File::Temp;
34
35 eval {
36 my $sbo = Net::SBo->new;
37 $sbo->get($url->path, $fh->filename, treeish => $url->branch);
38 };
39 if ($@) {
40 return HTTP::Response->new(HTTP::Status::RC_INTERNAL_SERVER_ERROR, $@);
41 }
42
43 my $response = HTTP::Response->new(HTTP::Status::RC_OK);
44 $size = -s $fh;
45 binmode($fh);
46 $response = $self->collect($arg, $response,
47 sub {
48 my $content = "";
49 my $bytes = sysread($fh, $content, $size);
50 return \$content if $bytes > 0;
51 return \ "";
52 });
53 $response->header('Content-Type', 'application/x-tar');
54 $response->header('Content-Length', $size);
55
56 $response;
57}
58
591;
60
61
diff --git a/lib/Net/SBo.pm b/lib/Net/SBo.pm
new file mode 100644
index 0000000..bc4a3e1
--- /dev/null
+++ b/lib/Net/SBo.pm
@@ -0,0 +1,289 @@
1package Net::SBo;
2use strict;
3use warnings;
4use POSIX::Run::Capture qw(:all);
5use POSIX qw(:sys_wait_h strerror);
6use Carp;
7use File::Basename;
8use File::Spec;
9use File::Path qw(make_path);
10use Archive::Tar;
11
12our $VERSION = '1.00';
13
14=head1 NAME
15
16Net::SBo - Access slackbuilds.org repository
17
18=head1 SYNOPSIS
19
20 use Net::SBo;
21
22 $sbo = new Net::SBo;
23 $sbo = new Net::SBo(dir => $cachedir);
24
25 $path = $sbo->find('mailutils');
26 ($path,$commit) = $sbo->find('mailutils', 'HEAD^');
27
28 $sbo->scan('HEAD^');
29 @files = $sbo->get($path, $dest, %opts);
30
31 $x = $sbo->commit;
32
33=head1 DESCRIPTION
34
35B<Net::SBo> provides access to the L<slackbuilds.org> repository, allowing
36the user to download slackbuild archives for arbitrary packages.
37
38=head1 Object Methods
39
40=head2 Net::SBo->new(%opts)
41
42Returns a new B<SBo> object. A bare mirror of the slackbuilds repository is
43created in the directory B<$HOME/.sbo.git>, unless it already exists, in
44which case it is synchronized with the master repository. Optional keyword
45arguments alter the default settings:
46
47=over 4
48
49=item B<dir>
50
51Name of the local slackbuilds mirror to use.
52
53=item B<repo>
54
55URL of the slackbuilds repository. Default is
56L<git://git.slackbuilds.org/slackbuilds.git>.
57
58=back
59
60If B<dir> is not given, the path to the repository is read from the
61environment variable B<SBO_LOCAL_REPOSITORY>. If it is not set, it
62defaults to B<.sbo.git> in the user home directory.
63
64=cut
65
66my $default_repo = 'git://git.slackbuilds.org/slackbuilds.git';
67
68sub new {
69 my ($class, %args) = @_;
70 my $dir = delete $args{dir}
71 || $ENV{SBO_LOCAL_REPOSITORY}
72 || File::Spec->catfile($ENV{HOME}, '.sbo.git');
73 my $repo = delete $args{repo} || $default_repo;
74
75 my $self = bless {}, $class;
76 my @cmd;
77 if (-d $dir) {
78 @cmd = (qw(git --git-dir), $dir, 'fetch', '-q')
79 } else {
80 @cmd = (qw(git clone -q --mirror), $repo, $dir);
81 }
82 if (@cmd) {
83 if (system(@cmd)) {
84 $self->procdiag($?, @cmd);
85 }
86 }
87 $self->{dir} = $dir;
88 $self->{repo} = $repo;
89
90 return $self;
91}
92
93sub procdiag {
94 my ($self, $status) = (shift, shift);
95 if (WIFEXITED($status)) {
96 return if $status == 0;
97 croak "command \""
98 . join(' ', @_)
99 . "\" terminated with code "
100 . WEXITSTATUS($status);
101 } elsif (WIFSIGNALED($status)) {
102 croak "command \""
103 . join(' ', @_)
104 . "\" terminated on signal "
105 . WTERMSIG($status);
106 } else {
107 croak "command \""
108 . join(' ', @_)
109 . "\" terminated with unrecogized code "
110 . $status;
111 }
112}
113
114=head2 $sbo->scan([$treeish])
115
116Scan the subtree. If I<$treeish> is not given, B<HEAD> is assumed.
117
118Normally, you won't need to use this method, as it is called internally
119when needed.
120
121=cut
122
123sub scan {
124 my ($self, $treeish) = @_;
125 $treeish //= 'HEAD';
126 return if (exists($self->{treeish}) && $self->{treeish} eq 'HEAD');
127 delete $self->{index};
128 delete $self->{treeish};
129 delete $self->{commit};
130
131 my @cmd = ('git', '--git-dir', $self->{dir},
132 qw(ls-tree --full-tree -r --name-only),
133 $treeish);
134 open(my $fh, '-|', @cmd)
135 or croak "git ls-tree failed: $!";
136 while (<$fh>) {
137 chomp;
138 my ($filename, $path, $suffix) = fileparse($_, '.SlackBuild');
139 if ($suffix eq '.SlackBuild') {
140 $self->{index}{$filename} = $path;
141 }
142 }
143 $self->{treeish} = $treeish;
144 # FIXME: Use 'git --git-dir ~/.sbo.git rev-parse $treeish' to convert it
145 # to the SHA.
146}
147
148=head2 $sbo->commit()
149
150Returns the SHA-1 hash identified the scanned commit.
151
152=cut
153
154sub commit {
155 my ($self) = @_;
156 unless ($self->{commit}) {
157 $self->scan;
158 my @cmd = ('git', '--git-dir', $self->{dir}, 'rev-parse',
159 $self->{treeish});
160
161 open(my $fh, '-|', @cmd) or croak "git rev-parse failed: $!";
162 chomp(my @a = <$fh>);
163 $self->{commit} = $a[0];
164 }
165 return $self->{commit};
166}
167
168=head2 $sbo->fi