/[gentoo-perl]/perl-info/trunk/bin/perl-info
Gentoo

Contents of /perl-info/trunk/bin/perl-info

Parent Directory Parent Directory | Revision Log Revision Log


Revision 107 - (show annotations) (download)
Sun Sep 24 14:57:13 2006 UTC (7 years, 11 months ago) by ian
File size: 10546 byte(s)
Style; cleanups; refactoring; backports from PortageXS
1 #!/usr/bin/perl
2
3 # -----------------------------------------------------------------------------
4 #
5 # perl-info
6 #
7 # date : 2006-09-24
8 # author : Christian Hartmann <ian@gentoo.org>
9 # version : 0.12
10 # license : GPL-2
11 # description : 'emerge --info' for perl
12 #
13 # header : $Header: $
14 #
15 # -----------------------------------------------------------------------------
16 #
17 # This program is free software; you can redistribute it and/or modify it under
18 # the terms of the GNU General Public License as published by the Free Software
19 # Foundation; either version 2 of the License, or (at your option) any later
20 # version.
21 #
22 # -----------------------------------------------------------------------------
23
24 # - modules >
25 use warnings;
26 use strict;
27 use DirHandle;
28 use Term::ANSIColor;
29
30 # - init vars & constants >
31 my $VERSION = "0.12";
32 my $portdir = getPortdir();
33 my @scan_portage_categories = ("dev-perl","perl-core","perl-gcpan");
34 my $pkgdbdir = "/var/db/pkg/";
35 my %excludeDirs = ("." => 1, ".." => 1, "metadata" => 1, "licenses" => 1, "eclass" => 1, "distfiles" => 1, "virtual" => 1, "profiles" => 1 , "CVS" => 1);
36
37 # - Print header >
38 printHeader();
39
40 # - Do some basic checks >
41 if (!-d $portdir) {
42 print_err("PORTDIR not set or incorrect! Aborting..\n");
43 exit(0);
44 }
45
46 if (!-d $pkgdbdir) {
47 print_err("/var/db/pkg inaccessible? Aborting..\n");
48 exit(0);
49 }
50
51 # - Start system analysis >
52 print_ok("Perl : ".(searchInstalledPackage("dev-lang/perl"))[0]." USE=\"".join(" ",getUseSettingsOfInstalledPackage("dev-lang/perl"))."\"\n");
53 print_ok("libperl: ".(searchInstalledPackage("sys-devel/libperl"))[0]." USE=\"".join(" ",getUseSettingsOfInstalledPackage("sys-devel/libperl"))."\"\n");
54 print "\n";
55
56 print_ok("INC:\n");
57 foreach (@INC) {
58 print " ".$_."\n";
59 }
60 print "\n";
61
62 foreach my $this_category (@scan_portage_categories) {
63 my $category_str_length = length($this_category)+1;
64 print_ok("Installed packages from category ".$this_category.":\n");
65 foreach(searchInstalledPackage($this_category."/*")) {
66 print " ".substr($_,$category_str_length,length($_)-$category_str_length)." USE=\"".join(" ",getUseSettingsOfInstalledPackage($_))."\"\n";
67 }
68 print "\n";
69 }
70
71 print_ok("eclasses:\n");
72 foreach my $eclassName ("perl-app","perl-module","perl-post") {
73 my $eclass = getFileContents($portdir."/eclass/".$eclassName.".eclass");
74 $eclass =~ s/\$Header: ([a-zA-Z0-9\/\.,-]+) ([0-9\.]+)/$2/g;
75 print " ".$eclassName.": ".$2."\n";
76 }
77 print "\n";
78 exit(0);
79
80 # -----------------------------------------------------------------------------
81 # subs >
82 # -----------------------------------------------------------------------------
83
84 # Description:
85 # Returns an array containing all installed packages that match $searchString
86 # @packages = searchInstalledPackage($searchString);
87 sub searchInstalledPackage {
88 my $searchString = shift; if (! $searchString) { $searchString=""; }
89
90 my $int_c = 0;
91 my $dhc;
92 my $dhp;
93 my $tc;
94 my $tp;
95 my @matches = ();
96
97 my $s_cat = "";
98 my $s_pak = "";
99 my $m_cat = 0;
100
101 # - escape special chars >
102 $searchString =~ s/\+/\\\+/g;
103
104 # - split >
105 if ($searchString=~m/\//) {
106 ($s_cat,$s_pak)=split(/\//,$searchString);
107 }
108 else {
109 $s_pak=$searchString;
110 }
111
112 $s_cat=~s/\*//g;
113 $s_pak=~s/\*//g;
114
115 # - read categories >
116 $dhc = new DirHandle($pkgdbdir);
117 if (defined $dhc) {
118 while (defined($tc = $dhc->read)) {
119 $m_cat=0;
120 if ($s_cat ne "") {
121 if ($tc=~m/$s_cat/i) {
122 $m_cat=1;
123 }
124 else {
125 next;
126 }
127 }
128
129 # - not excluded and $_ is a dir?
130 if (! $excludeDirs{$tc} && -d $pkgdbdir."/".$tc) {
131 $dhp = new DirHandle($pkgdbdir."/".$tc);
132 while (defined($tp = $dhp->read)) {
133 # - check if packagename matches
134 # (faster if we already check it now) >
135 if ($tp =~m/$s_pak/i || $s_pak eq "") {
136 # - not excluded and $_ is a dir?
137 if (! $excludeDirs{$tp} && -d $pkgdbdir."/".$tc."/".$tp) {
138 if (($s_cat ne "") && ($m_cat)) {
139 push(@matches,$tc."/".$tp);
140 }
141 elsif ($s_cat eq "") {
142 push(@matches,$tc."/".$tp);
143 }
144 }
145 }
146 }
147 undef $dhp;
148 }
149 }
150 }
151 undef $dhc;
152
153 return (sort @matches);
154 }
155
156 # Description:
157 # Returns the value of $param. Expects filecontents in $file.
158 # $valueOfKey = getParamFromFile($filecontents,$key);
159 # e.g.
160 # $valueOfKey = getParamFromFile(getFileContents("/path/to.ebuild","IUSE","firstseen");
161 sub getParamFromFile {
162 my $file = shift;
163 my $param = shift;
164 my $mode = shift; # ("firstseen","lastseen") - default is "lastseen"
165 my $c = 0;
166 my $d = 0;
167 my @lines = ();
168 my @aTmp = (); # temp (a)rray
169 my $sTmp = ""; # temp (s)calar
170 my $text = ""; # complete text/file after being cleaned up and striped
171 my $value = ""; # value of $param
172 my $this = "";
173
174 # - 1. split file in lines >
175 @lines = split(/\n/,$file);
176
177 # - 2 & 3 >
178 for($c=0;$c<=$#lines;$c++) {
179 # - 2. remove leading and trailing whitespaces and tabs from every line >
180 $lines[$c]=~s/^[ |\t]+//; # leading whitespaces and tabs
181 $lines[$c]=~s/[ |\t]+$//; # trailing whitespaces and tabs
182
183 # - 3. remove comments >
184 $lines[$c]=~s/#(.*)//g;
185
186 if ($lines[$c]=~/^$param="(.*)"/) {
187 # single-line with quotationmarks >
188 $value=$1;
189
190 if ($mode eq "firstseen") {
191 # - 6. clean up value >
192 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
193 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
194 $value=~s/\t/ /g; # replace tabs with whitespaces
195 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
196 return $value;
197 }
198 }
199 elsif ($lines[$c]=~/^$param="(.*)/) {
200 # multi-line with quotationmarks >
201 $value=$1." ";
202 for($d=$c+1;$d<=$#lines;$d++) {
203 # - look for quotationmark >
204 if ($lines[$d]=~/(.*)"/) {
205 # - found quotationmark; append contents and leave loop >
206 $value.=$1;
207 last;
208 }
209 else {
210 # - no quotationmark found; append line contents to $value >
211 $value.=$lines[$d]." ";
212 }
213 }
214
215 if ($mode eq "firstseen") {
216 # - 6. clean up value >
217 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
218 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
219 $value=~s/\t/ /g; # replace tabs with whitespaces
220 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
221 return $value;
222 }
223 }
224 elsif ($lines[$c]=~/^$param=(.*)/) {
225 # - single-line without quotationmarks >
226 $value=$1;
227
228 if ($mode eq "firstseen") {
229 # - 6. clean up value >
230 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
231 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
232 $value=~s/\t/ /g; # replace tabs with whitespaces
233 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
234 return $value;
235 }
236 }
237 }
238
239 # - 6. clean up value >
240 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
241 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
242 $value=~s/\t/ /g; # replace tabs with whitespaces
243 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
244
245 return $value;
246 }
247
248 # Description:
249 # Returnvalue is the content of the given file.
250 # $filecontent = getFileContents($file);
251 sub getFileContents {
252 open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]);
253 my $content = do{local $/; <FH>};
254 close(FH);
255 return $content;
256 }
257
258 # Description:
259 # Returnvalue is PORTDIR from make.conf or make.globals (make.conf overrules make.globals).
260 # $portdir = getPortdir();
261 sub getPortdir {
262 return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen");
263 }
264
265 # Description:
266 # Prints a fancy header.
267 sub printHeader {
268 print "\n".color('green bold')." perl-info".color('reset')." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n";
269 print " Distributed under the terms of the GPL-2\n\n";
270 }
271
272 # Description:
273 # Returns useflag settings of the given (installed) package.
274 # @useflags = $pxs->getUseSettingsOfInstalledPackage("dev-perl/perl-5.8.8-r3");
275 sub getUseSettingsOfInstalledPackage {
276 my $package = shift;
277 my $packagepath = (searchInstalledPackage($package))[0];
278 my $tmp_filecontents = "";
279 my @package_IUSE = ();
280 my @package_USE = ();
281 my @USEs = ();
282
283 $tmp_filecontents = getFileContents($pkgdbdir."/".$packagepath."/IUSE");
284 $tmp_filecontents =~s/\n//g;
285 @package_IUSE = split(/ /,$tmp_filecontents);
286 $tmp_filecontents = getFileContents($pkgdbdir."/".$packagepath."/USE");
287 $tmp_filecontents =~s/\n//g;
288 @package_USE = split(/ /,$tmp_filecontents);
289
290 foreach my $thisIUSE (@package_IUSE) {
291 next if ($thisIUSE eq "");
292 my $hasuse = "-";
293 foreach my $thisUSE (@package_USE) {
294 if ($thisIUSE eq $thisUSE) {
295 $hasuse="";
296 last;
297 }
298 }
299 push(@USEs,$hasuse.$thisIUSE);
300 }
301
302 return @USEs;
303 }
304
305 # Description:
306 # Prints gentoo-style items.
307 sub printColored {
308 print ' ' . color(shift) . '* ' . color("reset") . shift() , @_;
309 }
310
311 # Description:
312 # Wrapper for printColored >
313 sub print_ok {
314 printColored('green bold',shift);
315 }
316
317 # Description:
318 # Wrapper for printColored >
319 sub print_err {
320 printColored('red bold',shift);
321 }
322
323 # Description:
324 # Wrapper for printColored >
325 sub print_info {
326 printColored('yellow bold',shift);
327 }
328
329 # - Here comes the POD >
330
331 =head1 NAME
332
333 perl-info - gather systems perl info
334
335 =head1 VERSION
336
337 This document refers to version 0.12 of perl-info
338
339 =head1 SYNOPSIS
340
341 perl-info
342
343 =head1 DESCRIPTION
344
345 perl-info shall help developers getting sufficient information about the
346 users perl installation when needed.
347
348 =head1 AGRUMENTS
349
350 perl-info does not have any arguments yet.
351
352 =head1 AUTHOR
353
354 Christian Hartmann <ian@gentoo.org>
355
356 =head1 TODO
357
358 Put your stuff here and poke me.
359
360 =head1 REPORTING BUGS
361
362 Please report bugs via http://bugs.gentoo.org/ or https://bugs.gentoo.org/
363
364 =head1 LICENSE
365
366 perl-info - gather systems perl info
367 Copyright (C) 2006 Christian Hartmann
368
369 This program is free software; you can redistribute it and/or modify
370 it under the terms of the GNU General Public License as published by
371 the Free Software Foundation; either version 2 of the License, or
372 (at your option) any later version.
373
374 This program is distributed in the hope that it will be useful,
375 but WITHOUT ANY WARRANTY; without even the implied warranty of
376 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
377 GNU General Public License for more details.
378
379 You should have received a copy of the GNU General Public License
380 along with this program; if not, write to the Free Software
381 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
382
383 =cut

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20