diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-19 16:36:58 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2018-06-19 16:52:11 +0200 |
commit | 5091d2c21569478bab5eeac0ad1cf6c4e459ab87 (patch) | |
tree | 850e286ecdbde28bb70f490975eb9a83b2a61ba9 | |
parent | 7118ffe16d97b2a589047408ea704133a3aa28ad (diff) | |
download | slackbuilder-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.pm | 61 | ||||
-rw-r--r-- | lib/Net/SBo.pm | 289 | ||||
-rw-r--r-- | lib/SlackBuild/Registry/Backend/FS.pm | 66 | ||||
-rw-r--r-- | lib/URI/sbo.pm | 37 | ||||
-rwxr-xr-x | slackbuilder | 24 |
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 @@ | |||
1 | package LWP::Protocol::sbo; | ||
2 | use base qw(LWP::Protocol); | ||
3 | use strict; | ||
4 | use warnings; | ||
5 | use File::Temp; | ||
6 | |||
7 | our $VERSION = '1.00'; | ||
8 | |||
9 | use HTTP::Request; | ||
10 | use HTTP::Response; | ||
11 | use HTTP::Status; | ||
12 | |||
13 | sub 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 | |||
59 | 1; | ||
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 @@ | |||
1 | package Net::SBo; | ||
2 | use strict; | ||
3 | use warnings; | ||
4 | use POSIX::Run::Capture qw(:all); | ||
5 | use POSIX qw(:sys_wait_h strerror); | ||
6 | use Carp; | ||
7 | use File::Basename; | ||
8 | use File::Spec; | ||
9 | use File::Path qw(make_path); | ||
10 | use Archive::Tar; | ||
11 | |||
12 | our $VERSION = '1.00'; | ||
13 | |||
14 | =head1 NAME | ||
15 | |||
16 | Net::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 | |||
35 | B<Net::SBo> provides access to the L<slackbuilds.org> repository, allowing | ||
36 | the user to download slackbuild archives for arbitrary packages. | ||
37 | |||
38 | =head1 Object Methods | ||
39 | |||
40 | =head2 Net::SBo->new(%opts) | ||
41 | |||
42 | Returns a new B<SBo> object. A bare mirror of the slackbuilds repository is | ||
43 | created in the directory B<$HOME/.sbo.git>, unless it already exists, in | ||
44 | which case it is synchronized with the master repository. Optional keyword | ||
45 | arguments alter the default settings: | ||
46 | |||
47 | =over 4 | ||
48 | |||
49 | =item B<dir> | ||
50 | |||
51 | Name of the local slackbuilds mirror to use. | ||
52 | |||
53 | =item B<repo> | ||
54 | |||
55 | URL of the slackbuilds repository. Default is | ||
56 | L<git://git.slackbuilds.org/slackbuilds.git>. | ||
57 | |||
58 | =back | ||
59 | |||
60 | If B<dir> is not given, the path to the repository is read from the | ||
61 | environment variable B<SBO_LOCAL_REPOSITORY>. If it is not set, it | ||
62 | defaults to B<.sbo.git> in the user home directory. | ||
63 | |||
64 | =cut | ||
65 | |||
66 | my $default_repo = 'git://git.slackbuilds.org/slackbuilds.git'; | ||
67 | |||
68 | sub 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 | |||
93 | sub 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 | |||
116 | Scan the subtree. If I<$treeish> is not given, B<HEAD> is assumed. | ||
117 | |||
118 | Normally, you won't need to use this method, as it is called internally | ||
119 | when needed. | ||
120 | |||
121 | =cut | ||
122 | |||
123 | sub 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 | |||
150 | Returns the SHA-1 hash identified the scanned commit. | ||
151 | |||
152 | =cut | ||
153 | |||
154 | sub 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 |