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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20