comparison: openpkg/search.pl
openpkg/search.pl
- changeset 540
- 6becb64fe77d
equal
deleted
inserted
replaced
| -1:000000000000 | 0:c3ff11949f1e |
|---|---|
| 1 ## | |
| 2 ## search.pl -- OpenPKG Package Searching | |
| 3 ## Copyright (c) 2011-2012 OpenPKG GmbH <http://openpkg.com/> | |
| 4 ## | |
| 5 ## This software is property of the OpenPKG GmbH, DE MUC HRB 160208. | |
| 6 ## All rights reserved. Licenses which grant limited permission to use, | |
| 7 ## copy, modify and distribute this software are available from the | |
| 8 ## OpenPKG GmbH. | |
| 9 ## | |
| 10 ## THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED | |
| 11 ## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF | |
| 12 ## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. | |
| 13 ## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR | |
| 14 ## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | |
| 15 ## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | |
| 16 ## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF | |
| 17 ## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND | |
| 18 ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, | |
| 19 ## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT | |
| 20 ## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF | |
| 21 ## SUCH DAMAGE. | |
| 22 ## | |
| 23 | |
| 24 require 5.003; | |
| 25 | |
| 26 # OpenPKG instance prefix and RPM | |
| 27 my $my_prefix = $ENV{'OPENPKG_PREFIX'}; | |
| 28 my $my_rpm = "$my_prefix/bin/openpkg rpm"; | |
| 29 delete $ENV{'OPENPKG_PREFIX'}; | |
| 30 | |
| 31 # program identification | |
| 32 my $progname = "search"; | |
| 33 my $progvers = "0.1.0"; | |
| 34 | |
| 35 # home-brewn getopt(3) style option parser | |
| 36 sub getopts ($$@) { | |
| 37 my ($opt_spec, $opts, @argv_orig) = @_; | |
| 38 my (%optf) = map { m/(\w)/; $1 => $_ } $opt_spec =~ m/(\w:|\w)/g; | |
| 39 my (@argv, $optarg); | |
| 40 | |
| 41 foreach (@argv_orig) { | |
| 42 if (@argv) { | |
| 43 push @argv, $_; | |
| 44 } elsif (defined $optarg) { | |
| 45 if (exists $opts->{$optarg}) { | |
| 46 $opts->{$optarg} .= " $_"; | |
| 47 } else { | |
| 48 $opts->{$optarg} = $_; | |
| 49 } | |
| 50 $optarg = undef; | |
| 51 } elsif (!/^[-]/) { | |
| 52 push @argv, $_; | |
| 53 } else { | |
| 54 while (/^\-(\w)(.*)/) { | |
| 55 if (exists $optf{$1}) { | |
| 56 if (length($optf{$1}) > 1) { | |
| 57 if ($2 ne '') { | |
| 58 if (exists $opts->{$1}) { | |
| 59 $opts->{$1} .= " $2"; | |
| 60 } else { | |
| 61 $opts->{$1} = $2; | |
| 62 } | |
| 63 } else { | |
| 64 $optarg = $1; | |
| 65 } | |
| 66 last; | |
| 67 } else { | |
| 68 $opts->{$1} = 1; | |
| 69 } | |
| 70 } else { | |
| 71 warn "openpkg:$prog_name:WARNING: unknown option $_\n"; | |
| 72 } | |
| 73 $_ = "-$2"; | |
| 74 } | |
| 75 } | |
| 76 } | |
| 77 if (defined $optarg) { | |
| 78 warn "openpkg:$prog_name:WARNING: option $optarg requires an argument\n"; | |
| 79 } | |
| 80 foreach my $opt (keys %optf) { | |
| 81 if (not exists $opts->{$opt}) { | |
| 82 $opts->{$opt} = (length($optf{$opt}) > 1 ? "" : 0); | |
| 83 } | |
| 84 } | |
| 85 return @argv; | |
| 86 } | |
| 87 | |
| 88 # execute a command | |
| 89 my $run_cache = {}; | |
| 90 sub run ($) { | |
| 91 my ($cmd) = @_; | |
| 92 my $out = $run_cache->{$cmd}; | |
| 93 if (not defined($out)) { | |
| 94 my @out = `$cmd`; | |
| 95 $out = [ @out ]; | |
| 96 $run_cache->{$cmd} = $out; | |
| 97 } | |
| 98 return (wantarray ? @{$out} : join(//, @{$out})); | |
| 99 } | |
| 100 | |
| 101 # determine reasonable temporary directory | |
| 102 my $tmpdir = ($ENV{"TMPDIR"} || "/tmp"); | |
| 103 | |
| 104 # parse command line options | |
| 105 my $opts = {}; | |
| 106 @ARGV = getopts("hvr:", $opts, @ARGV); | |
| 107 | |
| 108 # usage sanity check and usage help | |
| 109 sub usage { | |
| 110 my ($rc) = @_; | |
| 111 my $usage = "openpkg:$prog_name:USAGE: openpkg search <regex>\n"; | |
| 112 if ($rc == 0) { | |
| 113 print STDOUT $usage; | |
| 114 } | |
| 115 else { | |
| 116 print STDERR $usage; | |
| 117 } | |
| 118 exit($rc); | |
| 119 } | |
| 120 if ($opts->{"h"}) { | |
| 121 usage(0); | |
| 122 } | |
| 123 if (@ARGV == 0) { | |
| 124 usage(1); | |
| 125 } | |
| 126 | |
| 127 # take command line arguments | |
| 128 my $keyword = $ARGV[0]; | |
| 129 | |
| 130 # determine start URL | |
| 131 my $url = $opts->{"r"} || ""; | |
| 132 if ($url eq "") { | |
| 133 $url = run("$my_prefix/bin/openpkg release --fmt='%u' 2>/dev/null"); | |
| 134 $url =~ s/^\s+//s; | |
| 135 $url =~ s/\s+$//s; | |
| 136 } | |
| 137 if ($url eq "") { | |
| 138 print STDERR "openpkg:$prog_name:ERROR: no repository URL known\n"; | |
| 139 exit(1); | |
| 140 } | |
| 141 | |
| 142 # recursively download XML/RDF index | |
| 143 sub relurl ($$) { | |
| 144 my ($url, $suburl) = @_; | |
| 145 if ($suburl =~ m/^\w+:\/\//) { | |
| 146 $url = $suburl; | |
| 147 } | |
| 148 elsif ($suburl =~ m/^\//) { | |
| 149 $url = "file://$suburl"; | |
| 150 } | |
| 151 else { | |
| 152 $url =~ s/(\/)?\/*[^\/]*$/$1$suburl/; | |
| 153 } | |
| 154 1 while ($url =~ s/\/\.\//\//s); | |
| 155 1 while ($url =~ s/\/[^\/]+\/\.\.\//\//s); | |
| 156 return $url; | |
| 157 } | |
| 158 sub get_index ($) { | |
| 159 my ($url) = @_; | |
| 160 if ($url =~ m/^\//) { | |
| 161 $url = "file://$url"; | |
| 162 } | |
| 163 if ($url =~ m/\/$/) { | |
| 164 $url .= "00INDEX.rdf"; | |
| 165 } | |
| 166 my $cmd = "$my_prefix/bin/openpkg curl -s -o- \"$url\" 2>/dev/null"; | |
| 167 if ($url =~ m/\.bz2$/) { | |
| 168 $cmd .= " | $my_prefix/lib/openpkg/bzip2 -d -c"; | |
| 169 } | |
| 170 my $xml = run($cmd); | |
| 171 my @includes = (); | |
| 172 while ($xml =~ m/<Repository\s+[^>]*href="([^"]*)"/gs) { | |
| 173 push(@includes, $1); | |
| 174 } | |
| 175 foreach my $include (@includes) { | |
| 176 $xml .= get_index(relurl($url, $include)); | |
| 177 } | |
| 178 return $xml; | |
| 179 } | |
| 180 my $xml = get_index($url); | |
| 181 | |
| 182 # parse XML/RDF index | |
| 183 my $x = $xml; | |
| 184 $x =~ s/<rdf:Description\s+about="([^"]+)".*?>(.+?)<\/rdf:Description>/do1($1, $2), ''/sge; | |
| 185 sub do1 { | |
| 186 my ($nvr, $xml) = @_; | |
| 187 my ($name) = ($xml =~ m|<Name>(.+?)</Name>|s); | |
| 188 my ($vers) = ($xml =~ m|<Version>(.+?)</Version>|s); | |
| 189 my ($rele) = ($xml =~ m|<Release>(.+?)</Release>|s); | |
| 190 my ($summ) = ($xml =~ m|<Summary>(.+?)</Summary>|s); | |
| 191 my ($desc) = ($xml =~ m|<Description>(.+?)</Description>|s); | |
| 192 if ( $name =~ m|$keyword|si | |
| 193 or $summ =~ m|$keyword|si | |
| 194 or $desc =~ m|$keyword|si) { | |
| 195 do2($nvr, $name, $vers, $rele, $summ, $desc, $xml); | |
| 196 } | |
| 197 } | |
| 198 sub do2 { | |
| 199 my ($nvr, $name, $vers, $rele, $summ, $desc, $xml) = @_; | |
| 200 return if ($name eq "openpkg"); | |
| 201 if ($opts->{"v"}) { | |
| 202 # itemized verbose output | |
| 203 my ($dist) = ($xml =~ m|<Distribution>(.+?)</Distribution>|s); | |
| 204 my ($class) = ($xml =~ m|<Class>(.+?)</Class>|s); | |
| 205 my ($group) = ($xml =~ m|<Group>(.+?)</Group>|s); | |
| 206 my ($license) = ($xml =~ m|<License>(.+?)</License>|s); | |
| 207 my ($packager) = ($xml =~ m|<Packager>(.+?)</Packager>|s); | |
| 208 my ($url) = ($xml =~ m|<URL>(.+?)</URL>|s); | |
| 209 my ($vendor) = ($xml =~ m|<Vendor>(.+?)</Vendor>|s); | |
| 210 | |
| 211 print "Name: $name\n"; | |
| 212 print "Version: $vers\n"; | |
| 213 print "Release: $rele\n"; | |
| 214 print "Group: $group\n"; | |
| 215 print "Class: $class\n"; | |
| 216 print "Distrib: $dist\n"; | |
| 217 print "License: $license\n"; | |
| 218 print "Packager: $packager\n"; | |
| 219 print "Vendor: $vendor\n"; | |
| 220 print "Summary: $summ\n"; | |
| 221 print "URL: $url\n"; | |
| 222 | |
| 223 print "Description:\n"; | |
| 224 $desc =~ s/^\s+//mg; | |
| 225 $desc =~ s/\s+$//mg; | |
| 226 $desc =~ s/^/ /mg; | |
| 227 print "$desc\n"; | |
| 228 | |
| 229 my ($prov) = ($xml =~ m|<Provides>(.+?)</Provides>|s); | |
| 230 if (($prov || "") ne "") { | |
| 231 print "Provides:\n"; | |
| 232 $prov =~ s/<resource\s+equ="([^"]*)">(.+?)<\/resource>/do3($1, $2), ''/sge; | |
| 233 sub do3 { | |
| 234 my ($val, $name) = @_; | |
| 235 print " $name = $val\n"; | |
| 236 } | |
| 237 } | |
| 238 | |
| 239 print "\n"; | |
| 240 } | |
| 241 else { | |
| 242 # tabular brief output | |
| 243 printf("%-20s %-10s %-9s %s\n", $name, $vers, $rele, $summ); | |
| 244 } | |
| 245 } | |
| 246 |
