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

Diff of /perl-info/trunk/bin/perl-info

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 104 Revision 107
… …
2 2
3# ----------------------------------------------------------------------------- 3# -----------------------------------------------------------------------------
4# 4#
5# perl-info 5# perl-info
6# 6#
7# date : 2006-09-10 7# date : 2006-09-24
8# author : Christian Hartmann <ian@gentoo.org> 8# author : Christian Hartmann <ian@gentoo.org>
9# version : 0.11 9# version : 0.12
10# license : GPL-2 10# license : GPL-2
11# description : 'emerge --info' for perl 11# description : 'emerge --info' for perl
12# 12#
13# header : $Header: $ 13# header : $Header: $
14# 14#
… …
26use strict; 26use strict;
27use DirHandle; 27use DirHandle;
28use Term::ANSIColor; 28use Term::ANSIColor;
29 29
30# - init vars & constants > 30# - init vars & constants >
31my $VERSION = "0.11"; 31my $VERSION = "0.12";
32my $portdir = getPortdir(); 32my $portdir = getPortdir();
33my @scan_portage_categories = ("dev-perl","perl-core","perl-gcpan"); 33my @scan_portage_categories = ("dev-perl","perl-core","perl-gcpan");
34my $pkgdbdir = "/var/db/pkg/"; 34my $pkgdbdir = "/var/db/pkg/";
35my %excludeDirs = ("." => 1, ".." => 1, "metadata" => 1, "licenses" => 1, "eclass" => 1, "distfiles" => 1, "virtual" => 1, "profiles" => 1 , "CVS" => 1); 35my %excludeDirs = ("." => 1, ".." => 1, "metadata" => 1, "licenses" => 1, "eclass" => 1, "distfiles" => 1, "virtual" => 1, "profiles" => 1 , "CVS" => 1);
36 36
37# - init colors >
38my $yellow = color("yellow bold");
39my $green = color("bold green");
40my $white = color("bold white");
41my $cyan = color("bold cyan");
42my $red = color("bold red");
43my $reset = color("reset");
44
45# - Print header > 37# - Print header >
46printHeader(); 38printHeader();
47 39
48# - Do some basic checks > 40# - Do some basic checks >
49if (!-d $portdir) 41if (!-d $portdir) {
50{
51 print $red." *".$reset." PORTDIR not set or incorrect! Aborting..\n"; 42 print_err("PORTDIR not set or incorrect! Aborting..\n");
52 exit(0); 43 exit(0);
53} 44}
54 45
55if (!-d $pkgdbdir) 46if (!-d $pkgdbdir) {
56{
57 print $red." *".$reset." /var/db/pkg inaccessible? Aborting..\n"; 47 print_err("/var/db/pkg inaccessible? Aborting..\n");
58 exit(0); 48 exit(0);
59} 49}
60 50
61# - Start system analysis > 51# - Start system analysis >
62print $green." *".$reset." Perl : ".(searchInstalled($pkgdbdir,"dev-lang/perl"))[0]." USE=\"".join(" ",getUseSettingsOfPackage("dev-lang/perl"))."\"\n"; 52print_ok("Perl : ".(searchInstalledPackage("dev-lang/perl"))[0]." USE=\"".join(" ",getUseSettingsOfInstalledPackage("dev-lang/perl"))."\"\n");
63print $green." *".$reset." libperl: ".(searchInstalled($pkgdbdir,"sys-devel/libperl"))[0]." USE=\"".join(" ",getUseSettingsOfPackage("sys-devel/libperl"))."\"\n"; 53print_ok("libperl: ".(searchInstalledPackage("sys-devel/libperl"))[0]." USE=\"".join(" ",getUseSettingsOfInstalledPackage("sys-devel/libperl"))."\"\n");
64print "\n"; 54print "\n";
65 55
66print $green." *".$reset." INC:\n"; 56print_ok("INC:\n");
67foreach (@INC) 57foreach (@INC) {
68{
69 print " ".$_."\n"; 58 print " ".$_."\n";
70} 59}
71print "\n"; 60print "\n";
72 61
73foreach my $this_category (@scan_portage_categories) 62foreach my $this_category (@scan_portage_categories) {
74{
75 my $category_str_length = length($this_category)+1; 63 my $category_str_length = length($this_category)+1;
76 print $green." *".$reset." Installed packages from category ".$this_category.":\n"; 64 print_ok("Installed packages from category ".$this_category.":\n");
77 foreach(searchInstalled($pkgdbdir,$this_category."/*")) 65 foreach(searchInstalledPackage($this_category."/*")) {
78 {
79 print " ".substr($_,$category_str_length,length($_)-$category_str_length)." USE=\"".join(" ",getUseSettingsOfPackage($_))."\"\n"; 66 print " ".substr($_,$category_str_length,length($_)-$category_str_length)." USE=\"".join(" ",getUseSettingsOfInstalledPackage($_))."\"\n";
80 } 67 }
81 print "\n"; 68 print "\n";
82} 69}
83 70
84print $green." *".$reset." eclasses:\n"; 71print_ok("eclasses:\n");
85foreach my $eclassName ("perl-app","perl-module","perl-post") 72foreach my $eclassName ("perl-app","perl-module","perl-post") {
86{
87 my $eclass = getFileContents($portdir."/eclass/".$eclassName.".eclass"); 73 my $eclass = getFileContents($portdir."/eclass/".$eclassName.".eclass");
88 $eclass =~ s/\$Header: ([a-zA-Z0-9\/\.,-]+) ([0-9\.]+)/$2/g; 74 $eclass =~ s/\$Header: ([a-zA-Z0-9\/\.,-]+) ([0-9\.]+)/$2/g;
89 print " ".$eclassName.": ".$2."\n"; 75 print " ".$eclassName.": ".$2."\n";
90} 76}
91print "\n"; 77print "\n";
… …
94# ----------------------------------------------------------------------------- 80# -----------------------------------------------------------------------------
95# subs > 81# subs >
96# ----------------------------------------------------------------------------- 82# -----------------------------------------------------------------------------
97 83
98# Description: 84# Description:
99# Returns an array containing all packages that match $searchString 85# Returns an array containing all installed packages that match $searchString
100# @packages = searchInstalled($pkgdbdir,$searchString); 86# @packages = searchInstalledPackage($searchString);
101sub searchInstalled 87sub searchInstalledPackage {
102{
103 my $pkgdbdir = shift;
104 my $searchString = shift; if (! $searchString) { $searchString=""; } 88 my $searchString = shift; if (! $searchString) { $searchString=""; }
105 89
106 my $int_c = 0; 90 my $int_c = 0;
107 my $dhc; 91 my $dhc;
108 my $dhp; 92 my $dhp;
… …
116 100
117 # - escape special chars > 101 # - escape special chars >
118 $searchString =~ s/\+/\\\+/g; 102 $searchString =~ s/\+/\\\+/g;
119 103
120 # - split > 104 # - split >
121 if ($searchString=~m/\//) 105 if ($searchString=~m/\//) {
122 {
123 ($s_cat,$s_pak)=split(/\//,$searchString); 106 ($s_cat,$s_pak)=split(/\//,$searchString);
124 } 107 }
125 else 108 else {
126 {
127 $s_pak=$searchString; 109 $s_pak=$searchString;
128 } 110 }
129 111
130 $s_cat=~s/\*//g; 112 $s_cat=~s/\*//g;
131 $s_pak=~s/\*//g; 113 $s_pak=~s/\*//g;
132 114
133 # - read categories > 115 # - read categories >
134 $dhc = new DirHandle($pkgdbdir); 116 $dhc = new DirHandle($pkgdbdir);
135 if (defined $dhc) 117 if (defined $dhc) {
136 {
137 while (defined($tc = $dhc->read)) 118 while (defined($tc = $dhc->read)) {
138 {
139 $m_cat=0; 119 $m_cat=0;
140 if ($s_cat ne "") 120 if ($s_cat ne "") {
141 {
142 if ($tc=~m/$s_cat/i) 121 if ($tc=~m/$s_cat/i) {
143 {
144 $m_cat=1; 122 $m_cat=1;
145 } 123 }
146 else 124 else {
147 {
148 next; 125 next;
149 } 126 }
150 } 127 }
151 128
152 # - not excluded and $_ is a dir? 129 # - not excluded and $_ is a dir?
153 if (! $excludeDirs{$tc} && -d $pkgdbdir."/".$tc) 130 if (! $excludeDirs{$tc} && -d $pkgdbdir."/".$tc) {
154 {
155 $dhp = new DirHandle($pkgdbdir."/".$tc); 131 $dhp = new DirHandle($pkgdbdir."/".$tc);
156 while (defined($tp = $dhp->read)) 132 while (defined($tp = $dhp->read)) {
157 {
158 # - check if packagename matches 133 # - check if packagename matches
159 # (faster if we already check it now) > 134 # (faster if we already check it now) >
160 if ($tp =~m/$s_pak/i || $s_pak eq "") 135 if ($tp =~m/$s_pak/i || $s_pak eq "") {
161 {
162 # - not excluded and $_ is a dir? 136 # - not excluded and $_ is a dir?
163 if (! $excludeDirs{$tp} && -d $pkgdbdir."/".$tc."/".$tp) 137 if (! $excludeDirs{$tp} && -d $pkgdbdir."/".$tc."/".$tp) {
164 {
165 if (($s_cat ne "") && ($m_cat)) 138 if (($s_cat ne "") && ($m_cat)) {
166 {
167 push(@matches,$tc."/".$tp); 139 push(@matches,$tc."/".$tp);
168 } 140 }
169 elsif ($s_cat eq "") 141 elsif ($s_cat eq "") {
170 {
171 push(@matches,$tc."/".$tp); 142 push(@matches,$tc."/".$tp);
172 } 143 }
173 } 144 }
174 } 145 }
175
176 } 146 }
177 undef $dhp; 147 undef $dhp;
178 } 148 }
179 } 149 }
180 } 150 }
… …
186# Description: 156# Description:
187# Returns the value of $param. Expects filecontents in $file. 157# Returns the value of $param. Expects filecontents in $file.
188# $valueOfKey = getParamFromFile($filecontents,$key); 158# $valueOfKey = getParamFromFile($filecontents,$key);
189# e.g. 159# e.g.
190# $valueOfKey = getParamFromFile(getFileContents("/path/to.ebuild","IUSE","firstseen"); 160# $valueOfKey = getParamFromFile(getFileContents("/path/to.ebuild","IUSE","firstseen");
191sub getParamFromFile 161sub getParamFromFile {
192{
193 my $file = shift; 162 my $file = shift;
194 my $param = shift; 163 my $param = shift;
195 my $mode = shift; # ("firstseen","lastseen") - default is "lastseen" 164 my $mode = shift; # ("firstseen","lastseen") - default is "lastseen"
196 my $c = 0; 165 my $c = 0;
197 my $d = 0; 166 my $d = 0;
… …
204 173
205 # - 1. split file in lines > 174 # - 1. split file in lines >
206 @lines = split(/\n/,$file); 175 @lines = split(/\n/,$file);
207 176
208 # - 2 & 3 > 177 # - 2 & 3 >
209 for($c=0;$c<=$#lines;$c++) 178 for($c=0;$c<=$#lines;$c++) {
210 {
211 # - 2. remove leading and trailing whitespaces and tabs from every line > 179 # - 2. remove leading and trailing whitespaces and tabs from every line >
212 $lines[$c]=~s/^[ |\t]+//; # leading whitespaces and tabs 180 $lines[$c]=~s/^[ |\t]+//; # leading whitespaces and tabs
213 $lines[$c]=~s/[ |\t]+$//; # trailing whitespaces and tabs 181 $lines[$c]=~s/[ |\t]+$//; # trailing whitespaces and tabs
214 182
215 # - 3. remove comments > 183 # - 3. remove comments >
216 $lines[$c]=~s/#(.*)//g; 184 $lines[$c]=~s/#(.*)//g;
217 185
218 if ($lines[$c]=~/^$param="(.*)"/) 186 if ($lines[$c]=~/^$param="(.*)"/) {
219 {
220 # single-line with quotationmarks > 187 # single-line with quotationmarks >
221 $value=$1; 188 $value=$1;
222 189
223 if ($mode eq "firstseen") 190 if ($mode eq "firstseen") {
224 {
225 # - 6. clean up value > 191 # - 6. clean up value >
226 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs 192 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
227 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs 193 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
228 $value=~s/\t/ /g; # replace tabs with whitespaces 194 $value=~s/\t/ /g; # replace tabs with whitespaces
229 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace 195 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
230 return $value; 196 return $value;
231 } 197 }
232 } 198 }
233 elsif ($lines[$c]=~/^$param="(.*)/) 199 elsif ($lines[$c]=~/^$param="(.*)/) {
234 {
235 # multi-line with quotationmarks > 200 # multi-line with quotationmarks >
236 $value=$1." "; 201 $value=$1." ";
237 for($d=$c+1;$d<=$#lines;$d++) 202 for($d=$c+1;$d<=$#lines;$d++) {
238 {
239 # - look for quotationmark > 203 # - look for quotationmark >
240 if ($lines[$d]=~/(.*)"/) 204 if ($lines[$d]=~/(.*)"/) {
241 {
242 # - found quotationmark; append contents and leave loop > 205 # - found quotationmark; append contents and leave loop >
243 $value.=$1; 206 $value.=$1;
244 last; 207 last;
245 } 208 }
246 else 209 else {
247 {
248 # - no quotationmark found; append line contents to $value > 210 # - no quotationmark found; append line contents to $value >
249 $value.=$lines[$d]." "; 211 $value.=$lines[$d]." ";
250 } 212 }
251 } 213 }
252 214
253 if ($mode eq "firstseen") 215 if ($mode eq "firstseen") {
254 {
255 # - 6. clean up value > 216 # - 6. clean up value >
256 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs 217 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
257 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs 218 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
258 $value=~s/\t/ /g; # replace tabs with whitespaces 219 $value=~s/\t/ /g; # replace tabs with whitespaces
259 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace 220 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
260 return $value; 221 return $value;
261 } 222 }
262 } 223 }
263 elsif ($lines[$c]=~/^$param=(.*)/) 224 elsif ($lines[$c]=~/^$param=(.*)/) {
264 {
265 # - single-line without quotationmarks > 225 # - single-line without quotationmarks >
266 $value=$1; 226 $value=$1;
267 227
268 if ($mode eq "firstseen") 228 if ($mode eq "firstseen") {
269 {
270 # - 6. clean up value > 229 # - 6. clean up value >
271 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs 230 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
272 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs 231 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
273 $value=~s/\t/ /g; # replace tabs with whitespaces 232 $value=~s/\t/ /g; # replace tabs with whitespaces
274 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace 233 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
… …
287} 246}
288 247
289# Description: 248# Description:
290# Returnvalue is the content of the given file. 249# Returnvalue is the content of the given file.
291# $filecontent = getFileContents($file); 250# $filecontent = getFileContents($file);
292sub getFileContents 251sub getFileContents {
293{
294 open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]); 252 open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]);
295 my $content = do{local $/; <FH>}; 253 my $content = do{local $/; <FH>};
296 close(FH); 254 close(FH);
297 return $content; 255 return $content;
298} 256}
299 257
300# Description: 258# Description:
301# Returnvalue is PORTDIR from make.conf or make.globals (make.conf overrules make.globals). 259# Returnvalue is PORTDIR from make.conf or make.globals (make.conf overrules make.globals).
302# $portdir = getPortdir(); 260# $portdir = getPortdir();
303sub getPortdir 261sub getPortdir {
304{
305 return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen"); 262 return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen");
306} 263}
307 264
308# Description: 265# Description:
309# Prints a fancy header. 266# Prints a fancy header.
310sub printHeader 267sub printHeader {
311{
312 print "\n";
313 print $green." perl-info".$reset." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n"; 268 print "\n".color('green bold')." perl-info".color('reset')." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n";
314 print " Distributed under the terms of the GPL-2\n"; 269 print " Distributed under the terms of the GPL-2\n\n";
315 print "\n";
316} 270}
317 271
318# Description: 272# Description:
319# Returns useflag settings of the given (installed) package. 273# Returns useflag settings of the given (installed) package.
320# @useflags = getUseSettingsOfPackage("dev-perl/perl-5.8.8-r3"); 274# @useflags = $pxs->getUseSettingsOfInstalledPackage("dev-perl/perl-5.8.8-r3");
321sub getUseSettingsOfPackage 275sub getUseSettingsOfInstalledPackage {
322{
323 my $package = shift; 276 my $package = shift;
324 my $packagepath = (searchInstalled($pkgdbdir,$package))[0]; 277 my $packagepath = (searchInstalledPackage($package))[0];
325 my $tmp_filecontents = ""; 278 my $tmp_filecontents = "";
326 my @package_IUSE = (); 279 my @package_IUSE = ();
327 my @package_USE = (); 280 my @package_USE = ();
328 my @USEs = (); 281 my @USEs = ();
329 282
330 $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/IUSE"); 283 $tmp_filecontents = getFileContents($pkgdbdir."/".$packagepath."/IUSE");
331 $tmp_filecontents=~s/\n//g; 284 $tmp_filecontents =~s/\n//g;
332 @package_IUSE = split(/ /,$tmp_filecontents); 285 @package_IUSE = split(/ /,$tmp_filecontents);
333 $tmp_filecontents=getFileContents($pkgdbdir."/".$packagepath."/USE"); 286 $tmp_filecontents = getFileContents($pkgdbdir."/".$packagepath."/USE");
334 $tmp_filecontents=~s/\n//g; 287 $tmp_filecontents =~s/\n//g;
335 @package_USE = split(/ /,$tmp_filecontents); 288 @package_USE = split(/ /,$tmp_filecontents);
336 289
337
338 foreach my $thisIUSE (@package_IUSE) 290 foreach my $thisIUSE (@package_IUSE) {
339 { 291 next if ($thisIUSE eq "");
340 my $hasuse = "-"; 292 my $hasuse = "-";
341 foreach my $thisUSE (@package_USE) 293 foreach my $thisUSE (@package_USE) {
342 {
343 if ($thisIUSE eq $thisUSE) 294 if ($thisIUSE eq $thisUSE) {
344 {
345 $hasuse=""; 295 $hasuse="";
346 last; 296 last;
347 } 297 }
348 } 298 }
349 push(@USEs,$hasuse.$thisIUSE) unless ($thisIUSE eq ""); 299 push(@USEs,$hasuse.$thisIUSE);
350 } 300 }
351 301
352 return @USEs; 302 return @USEs;
353} 303}
354 304
305# Description:
306# Prints gentoo-style items.
307sub printColored {
308 print ' ' . color(shift) . '* ' . color("reset") . shift() , @_;
309}
310
311# Description:
312# Wrapper for printColored >
313sub print_ok {
314 printColored('green bold',shift);
315}
316
317# Description:
318# Wrapper for printColored >
319sub print_err {
320 printColored('red bold',shift);
321}
322
323# Description:
324# Wrapper for printColored >
325sub print_info {
326 printColored('yellow bold',shift);
327}
328
355# - Here comes the POD > 329# - Here comes the POD >
356 330
357=head1 NAME 331=head1 NAME
358 332
359perl-info - gather systems perl info 333perl-info - gather systems perl info
360 334
361=head1 VERSION 335=head1 VERSION
362 336
363This document refers to version 0.11 of perl-info 337This document refers to version 0.12 of perl-info
364 338
365=head1 SYNOPSIS 339=head1 SYNOPSIS
366 340
367perl-info 341perl-info
368 342
Legend:
Removed from v.104  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.13