/[gentoo-perl]/up2date-ng/trunk/bin/up2date-ng.pl
Gentoo

Contents of /up2date-ng/trunk/bin/up2date-ng.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 111 - (show annotations) (download) (as text)
Mon Oct 9 01:13:15 2006 UTC (8 years, 2 months ago) by yuval
File MIME type: text/x-perl
File size: 28768 byte(s)
package.altname => up2date_package.altname
1 #!/usr/bin/perl
2
3 # -----------------------------------------------------------------------------
4 #
5 # up2date-ng.pl
6 #
7 # date : 2006-09-24
8 # author : Christian Hartmann <ian@gentoo.org>
9 # version : 0.22
10 # license : GPL-2
11 # description : Scripts that compares the versions of perl packages in portage
12 # with the version of the packages on CPAN
13 #
14 # header : $Header: $
15 #
16 # -----------------------------------------------------------------------------
17 #
18 # This program is free software; you can redistribute it and/or modify it under
19 # the terms of the GNU General Public License as published by the Free Software
20 # Foundation; either version 2 of the License, or (at your option) any later
21 # version.
22 #
23 # -----------------------------------------------------------------------------
24
25 # - modules >
26 use warnings;
27 use strict;
28 use DirHandle;
29 use CPAN;
30 use Term::ANSIColor;
31 use Getopt::Long;
32 Getopt::Long::Configure("bundling");
33
34 # - init vars & contants >
35 my $VERSION = "0.22";
36 my $portdir = getPortdir();
37 my @scan_portage_categories = ();
38 my $up2date_config_dir = "./";
39 my $category_list_file = $up2date_config_dir."up2date_category.list";
40 my $package_mask_file = $up2date_config_dir."up2date_package.mask";
41 my $package_altname_file = $up2date_config_dir."up2date_package.altname";
42 my @timeData = localtime(time);
43 my %modules = ();
44 my @tmp_availableVersions = ();
45 my @packages2update = ();
46 my @tmp_v = ();
47 my %pmask = ();
48 my @obsolete_switch = ();
49 my %paltname = ();
50 my @need_packagealtname = ();
51 my $cat_pkg = "";
52 my $cpan_searchstring = "";
53 my $html_packagelist_table = "";
54 my $mail_packagelist_table = "";
55 my $p_modulename = "";
56 my $xml_packagelist_table = "";
57 my $DEBUG = 0;
58 my $generate_all = 0;
59 my $generate_html = 0;
60 my $generate_mail = 0;
61 my $generate_packagelist = 0;
62 my $generate_xml = 0;
63 my $force_cpan_reload = 0;
64 my $hasVirtual = 0;
65 my $numberPackagesTotal = 0;
66 my $tmp;
67 my $mod;
68
69 # - get options >
70 printHeader();
71 GetOptions(
72 'debug' => \$DEBUG,
73 'force-cpan-reload' => \$force_cpan_reload,
74 'generate-all' => \$generate_all,
75 'generate-html' => \$generate_html,
76 'generate-mail' => \$generate_mail,
77 'generate-packagelist' => \$generate_packagelist,
78 'generate-xml' => \$generate_xml,
79 'help|h' => sub { exit(printUsage()); },
80 'portdir=s' => \$portdir,
81 'verbose|v' => \$obsolete_switch[0]
82 ) or exit(printUsage());
83
84 if ($obsolete_switch[0]) {
85 print_info("The -v option is now obsolete and will be removed in the next version. Please make sure your scripts do not use this option anymore!\n\n");
86 }
87
88 if ($generate_all) {
89 $generate_xml=1;
90 $generate_mail=1;
91 $generate_html=1;
92 $generate_packagelist=1;
93 }
94
95 # - Print settings and do some basic checks >
96 if (-d $portdir) {
97 print_ok("PORTDIR: ".$portdir."\n");
98 }
99 else {
100 print_err("PORTDIR not set or incorrect!\n\n");
101 exit(0);
102 }
103 print_ok("checking for dirs..\n");
104 foreach my $this_category (@scan_portage_categories) {
105 print " ".$portdir."/".$this_category;
106 if (-d $portdir."/".$this_category) {
107 print ".. ok\n";
108 }
109 else {
110 print ".. directory does not exist - aborting!\n\n";
111 exit(0);
112 }
113 }
114
115 # - Parse up2date_package.mask >
116 if (-f $package_mask_file) {
117 print_ok("parsing ".$package_mask_file."\n");
118
119 $pmask{'all'} = getFileContents($package_mask_file);
120
121 foreach my $line (split(/\n/,$pmask{'all'})) {
122 $line=~s/^[ |\t]+//; # leading whitespaces and tabs
123 $line=~s/[ |\t]+$//; # trailing whitespaces and tabs
124 $line=~s/#(.*)//g; # remove comments
125
126 if ($line ne "") {
127 if (substr($line,0,2) eq ">=") {
128 # - block package versions greater/equal then given version (e.g. >=dev-perl/Video-Info-0.999) >
129 $tmp=substr($line,2,length($line)-2);
130 $tmp=~s/([a-zA-Z\-]+)\/([a-zA-Z\-]+)-([0-9a-zA-Z\._\-]+)/$1\/$2/;
131 $pmask{'package'}{$tmp}{'version'}=$3;
132 $pmask{'package'}{$tmp}{'operator'}=">=";
133 }
134 elsif (substr($line,0,1) eq ">") {
135 # - block package versions greater then given version (e.g. >dev-perl/Video-Info-0.993) >
136 $tmp=substr($line,1,length($line)-1);
137 $tmp=~s/([a-zA-Z\-]+)\/([a-zA-Z\-]+)-([0-9a-zA-Z\._\-]+)/$1\/$2/;
138 $pmask{'package'}{$tmp}{'version'}=$3;
139 $pmask{'package'}{$tmp}{'operator'}=">";
140 }
141 elsif (substr($line,0,1) eq "=") {
142 # - block one package version (e.g. =dev-perl/Video-Info-0.999) >
143 $tmp=substr($line,1,length($line)-1);
144 $tmp=~s/([a-zA-Z\-]+)\/([a-zA-Z\-]+)-([0-9a-zA-Z\._\-]+)/$1\/$2/;
145 $pmask{'package'}{$tmp}{'version'}=$3;
146 $pmask{'package'}{$tmp}{'operator'}="=";
147 }
148 else {
149 # - block whole package (e.g. dev-perl/Video-Info) >
150 $tmp=$line;
151 $pmask{'package'}{$tmp}{'operator'}="*";
152 $pmask{'package'}{$tmp}{'version'}=0;
153 }
154
155 if ($DEBUG) {
156 print "package: ".$tmp."\n";
157 print "pmask{'package'}{'".$tmp."'}{'version'} : ".$pmask{'package'}{$tmp}{'version'}."\n";
158 print "pmask{'package'}{'".$tmp."'}{'operator'}: ".$pmask{'package'}{$tmp}{'operator'}."\n";
159 print "\n";
160 }
161 }
162 }
163 }
164 else {
165 print_info("No package.mask file available - Skipping\n");
166 }
167
168 # - Parse up2date_package.mask >
169 if (-f $package_altname_file) {
170 print_ok("parsing ".$package_altname_file."\n");
171
172 $paltname{'all'} = getFileContents($package_altname_file);
173
174 foreach my $line (split(/\n/,$paltname{'all'})) {
175 $line=~s/^[ |\t]+//; # leading whitespaces and tabs
176 $line=~s/[ |\t]+$//; # trailing whitespaces and tabs
177 $line=~s/#(.*)//g; # remove comments
178
179 if ($line ne "" && $line ne " ") {
180 $line=~s/[ |\t]+/ /; # remove multiple whitespaces and tabs
181 my @tmp=split(/ /,$line);
182
183 # - set $paltname{'portage'}{<portage-packagename>} = <cpan-packagename> (in lowercase) >
184 $paltname{'portage'}{lc($tmp[0])}=lc($tmp[1]);
185
186 if ($DEBUG) { print $tmp[0]." ".$paltname{'portage'}{lc($tmp[0])}."\n"; }
187 }
188 }
189 }
190 else {
191 print_info("No up2date_package.altname file available - Skipping\n");
192 }
193
194 # - Parse up2date_category.list >
195 if (-f $category_list_file) {
196 print_ok("parsing ".$category_list_file."\n");
197
198 foreach my $line (split(/\n/,getFileContents($category_list_file))) {
199 $line=~s/^[ |\t]+//; # leading whitespaces and tabs
200 $line=~s/[ |\t]+$//; # trailing whitespaces and tabs
201 $line=~s/#(.*)//g; # remove comments
202
203 if ($line ne "" && $line ne " ") {
204 push (@scan_portage_categories,$line);
205 if ($DEBUG) { print "adding '".$line."' to categories-searchlist\n"; }
206 }
207 }
208 }
209 else {
210 print_err("No category.list file available - Aborting\n\n");
211 exit(0);
212 }
213
214 # - get package/version info from portage and cpan >
215 print "\n";
216 print_ok("getting infos from CPAN\n");
217 getCPANPackages($force_cpan_reload);
218 print "\n";
219 print_ok("getting package information from portage-tree\n");
220 print "\n";
221 getPerlPackages();
222
223 # - get some work done >
224 print_ok("Available updates:\n");
225 foreach my $p_original_modulename (sort keys %{$modules{'portage_lc'}}) {
226 if ($DEBUG) { print $p_original_modulename."\n"; }
227 $p_modulename=$p_original_modulename;
228
229 if (! $modules{'cpan_lc'}{$p_modulename}) {
230 # - Could not find a matching package name - probably not a CPAN-module >
231 if ($DEBUG) { print "- Could not find CPAN-Module ('".$p_modulename."') for package '".$p_original_modulename."'!\n"; }
232
233 # - Look for an entry in up2date_package.altname for this package >
234 if ($paltname{'portage'}{$p_original_modulename}) {
235 # - found entry in up2date_package.altname >
236 if ($paltname{'portage'}{$p_original_modulename} ne "-") {
237 if ($DEBUG) { print "- Found entry for this package. Using '".$paltname{'portage'}{$p_original_modulename}."' now.\n"; }
238
239 $p_modulename=$paltname{'portage'}{$p_original_modulename};
240
241 if (! defined $modules{'cpan_lc'}{$p_modulename}) {
242 # - entry in up2date_package.altname does not match >
243 if ($DEBUG) { print "- Could not find CPAN-Module for given entry ('".$paltname{'portage'}{$p_original_modulename}."')! Please correct! Skipping..\n"; }
244 push(@need_packagealtname,$modules{'portage'}{$p_original_modulename}{'name'});
245 next;
246 }
247 }
248 else {
249 # - Package has been marked as "non-CPAN-module" >
250 if ($DEBUG) { print "- Package '".$p_modulename."' has been marked as non-CPAN-module. Skipping.\n"; }
251 next;
252 }
253 }
254 else {
255 # - no entry in up2date_package.altname found for $p_modulename >
256 if ($DEBUG) { print "- No entry in up2date_package.altname found for package '".$p_modulename."'!\n"; }
257 push(@need_packagealtname,$modules{'portage'}{$p_original_modulename}{'name'});
258 next;
259 }
260 }
261
262 # - Package found >
263
264 # - Convert portage version >
265 @tmp_v=split(/\./,$modules{'portage_lc'}{$p_original_modulename});
266 if ($#tmp_v > 1) {
267 if ($DEBUG) { print " converting version -> ".$modules{'portage_lc'}{$p_original_modulename}; }
268 $modules{'portage_lc'}{$p_original_modulename}=$tmp_v[0].".";
269 for (1..$#tmp_v) { $modules{'portage_lc'}{$p_original_modulename}.= $tmp_v[$_]; }
270 if ($DEBUG) { print " -> ".$modules{'portage_lc'}{$p_original_modulename}."\n"; }
271 }
272
273 # - Portage package matches CPAN package >
274 if ($modules{'cpan_lc'}{$p_modulename} > $modules{'portage_lc'}{$p_original_modulename}) {
275 # - package needs some lovin - check if package/version has been masked >
276 $cat_pkg = $modules{'portage'}{$p_original_modulename}{'category'}."/".$modules{'portage'}{$p_original_modulename}{'name'};
277
278 if (defined $pmask{'package'}{$cat_pkg}{'operator'}) {
279 # - package is masked >
280 if ($pmask{'package'}{$tmp}{'operator'} eq "*") {
281 # - all versions of this package have been masked - skip >
282 if ($DEBUG) { print "All versions of this package have been masked - skip\n"; }
283 next;
284 }
285 elsif ($pmask{'package'}{$tmp}{'operator'} eq ">=") {
286 # - all versions greater/equal than {'version'} have been masked >
287 if ($modules{'cpan_lc'}{$p_modulename} >= $pmask{'package'}{$tmp}{'version'}) {
288 # - cpan version has been masked - skip >
289 if ($DEBUG) { print "cpan version has been masked - skip\n"; }
290 next;
291 }
292 }
293 elsif ($pmask{'package'}{$tmp}{'operator'} eq ">") {
294 # - all versions greater than {'version'} have been masked >
295 if ($modules{'cpan_lc'}{$p_modulename} > $pmask{'package'}{$tmp}{'version'}) {
296 # - cpan version has been masked - skip >
297 if ($DEBUG) { print "cpan version has been masked - skip\n"; }
298 next;
299 }
300 }
301 elsif ($pmask{'package'}{$tmp}{'operator'} eq "=") {
302 # - this version has been masked >
303 if ($modules{'cpan_lc'}{$p_modulename} == $pmask{'package'}{$tmp}{'version'}) {
304 # - cpan version has been masked - skip >
305 if ($DEBUG) { print "cpan version has been masked - skip\n"; }
306 next;
307 }
308 }
309 }
310
311 # - print update msg >
312 print " ".$modules{'portage'}{$p_original_modulename}{'category'}."/".$modules{'portage'}{$p_original_modulename}{'name'}." needs updating. Ebuild: ".$modules{'portage_lc'}{$p_original_modulename}."; CPAN: ".$modules{'cpan_lc'}{$p_modulename}."\n";
313
314 # - store packagename - it needs to be updated >
315 push(@packages2update,$modules{'portage'}{$p_original_modulename}{'category'}."/".$modules{'portage'}{$p_original_modulename}{'name'});
316
317 # - check for virtuals >
318 if (-d $portdir."/virtual/perl-".$modules{'portage'}{$p_original_modulename}{'name'}) {
319 $hasVirtual=1;
320 }
321 else {
322 $hasVirtual=0;
323 }
324
325 # - generate searchstring for search.cpan.org >
326 $cpan_searchstring=$p_original_modulename;
327 $cpan_searchstring=~s/-/::/g;
328
329 if ($generate_xml) {
330 $xml_packagelist_table .= " <tr>\n";
331 if ($hasVirtual) {
332 $xml_packagelist_table .= " <ti><uri link=\"http://search.cpan.org/search?query=".$cpan_searchstring."&amp;mode=all\">".$modules{'portage'}{$p_original_modulename}{'name'}."</uri> (virtual/perl-".$modules{'portage'}{$p_original_modulename}{'name'}.")</ti>\n";
333 }
334 else {
335 $xml_packagelist_table .= " <ti><uri link=\"http://search.cpan.org/search?query=".$cpan_searchstring."&amp;mode=all\">".$modules{'portage'}{$p_original_modulename}{'name'}."</uri></ti>\n";
336 }
337 $xml_packagelist_table .= " <ti align=\"right\">".$modules{'portage_lc'}{$p_original_modulename}."</ti>\n";
338 $xml_packagelist_table .= " <ti align=\"right\">".$modules{'cpan_lc'}{$p_modulename}."</ti>\n";
339 $xml_packagelist_table .= " </tr>\n";
340 }
341
342 if ($generate_mail) {
343 $mail_packagelist_table .= " ".$modules{'portage'}{$p_original_modulename}{'name'};
344 if ($hasVirtual) { $mail_packagelist_table.=" *"; }
345 for(0..(35-($hasVirtual*2)-length($modules{'portage_lc'}{$p_original_modulename})-length($p_original_modulename))) {
346 $mail_packagelist_table .= " ";
347 }
348 $mail_packagelist_table .= " ".$modules{'portage_lc'}{$p_original_modulename};
349 for(0..(20-length($modules{'cpan_lc'}{$p_modulename}))) {
350 $mail_packagelist_table .= " ";
351 }
352 $mail_packagelist_table .= " ".$modules{'cpan_lc'}{$p_modulename};
353 $mail_packagelist_table .= "\n";
354 }
355
356 if ($generate_html) {
357 $html_packagelist_table .= "\t\t\t<tr>\n";
358 if ($hasVirtual) {
359 $html_packagelist_table .= "\t\t\t\t<td><a href=\"http://search.cpan.org/search?query=".$cpan_searchstring."&amp;mode=all\">".$modules{'portage'}{$p_original_modulename}{'name'}."</a> (virtual/perl-".$modules{'portage'}{$p_original_modulename}{'name'}.")</td>\n";
360 }
361 else {
362 $html_packagelist_table .= "\t\t\t\t<td><a href=\"http://search.cpan.org/search?query=".$cpan_searchstring."&amp;mode=all\">".$modules{'portage'}{$p_original_modulename}{'name'}."</a></td>\n";
363 }
364 $html_packagelist_table .= "\t\t\t\t<td align=\"right\">".$modules{'portage_lc'}{$p_original_modulename}."</td>\n";
365 $html_packagelist_table .= "\t\t\t\t<td align=\"right\">".$modules{'cpan_lc'}{$p_modulename}."</td>\n";
366 $html_packagelist_table .= "\t\t\t</tr>\n";
367 }
368 }
369 else {
370 if ($DEBUG) { print $p_original_modulename." is uptodate\n"; }
371 }
372 }
373
374 $numberPackagesTotal=(keys %{$modules{'portage_lc'}});
375 print "\n";
376 print_ok("total packages suspected as outdated: ".($#packages2update+1)." of ".$numberPackagesTotal."\n");
377 print "\n";
378
379 # - Generate xml >
380 if ($generate_xml) {
381 print_ok("called with --generate-xml\n");
382 my $xml = getFileContents("template_outdated-cpan-packages.xml");
383 my $dateXML = sprintf("%u-%02u-%02u",int($timeData[5]+1900),($timeData[4]+1),$timeData[3]);
384 my $numberOutdated = ($#packages2update+1);
385 chomp($xml_packagelist_table);
386 $xml =~ s/<TMPL_PACKAGELIST_TABLE>/$xml_packagelist_table/;
387 $xml =~ s/<TMPL_VAR_DATE>/$dateXML/g;
388 $xml =~ s/<TMPL_NUMBER_OUTDATED>/$numberOutdated/;
389 $xml =~ s/<TMPL_VAR_UP2DATE-NG-VERSION>/$VERSION/;
390 $xml =~ s/<TMPL_NUMBER_PACKAGES_TOTAL>/$numberPackagesTotal/;
391
392 print_ok("creating outdated-cpan-packages.xml\n");
393 open(FH,">outdated-cpan-packages.xml") || die ("Cannot open/write to file outdated-cpan-packages.xml");
394 print FH $xml;
395 close(FH);
396 print_ok("done!\n\n");
397 }
398
399 # - Generate mail >
400 if ($generate_mail) {
401 print_ok("called with --generate-mail\n");
402 my $mail = getFileContents("template_outdated-cpan-packages.mail");
403 $mail_packagelist_table .= "\nTotal packages suspected as outdated: ".($#packages2update+1)." of ".$numberPackagesTotal."\n";
404 $mail =~ s/<TMPL_PACKAGELIST_TABLE>/$mail_packagelist_table/;
405 $mail =~ s/<TMPL_VAR_UP2DATE-NG-VERSION>/$VERSION/;
406
407 print_ok("creating outdated-cpan-packages.mail\n");
408 open(FH,">outdated-cpan-packages.mail") || die ("Cannot open/write to file outdated-cpan-packages.mail");
409 print FH $mail;
410 close(FH);
411 print_ok("done!\n\n");
412 }
413
414 # - Generate html >
415 if ($generate_html) {
416 print_ok("called with --generate-html\n");
417 my $html = getFileContents("template_outdated-cpan-packages.html");
418 my $dateHTML = sprintf("%u-%02u-%02u",int($timeData[5]+1900),($timeData[4]+1),$timeData[3]);
419 my $numberOutdated = ($#packages2update+1);
420 chomp($html_packagelist_table);
421 $html =~ s/<TMPL_PACKAGELIST_TABLE>/$html_packagelist_table/;
422 $html =~ s/<TMPL_VAR_DATE>/$dateHTML/g;
423 $html =~ s/<TMPL_NUMBER_OUTDATED>/$numberOutdated/;
424 $html =~ s/<TMPL_VAR_UP2DATE-NG-VERSION>/$VERSION/;
425 $html =~ s/<TMPL_NUMBER_PACKAGES_TOTAL>/$numberPackagesTotal/;
426
427 print_ok("creating outdated-cpan-packages.html\n");
428 open(FH,">outdated-cpan-packages.html") || die ("Cannot open/write to file outdated-cpan-packages.html");
429 print FH $html;
430 close(FH);
431 print_ok("done!\n\n");
432 }
433
434 # - Generate packagelist >
435 if ($generate_packagelist) {
436 print_ok("called with --generate-packagelist\n");
437 print_ok("creating outdated-cpan-packages.packagelist\n");
438 open(FH,">outdated-cpan-packages.packagelist") || die ("Cannot open/write to file outdated-cpan-packages.packagelist");
439 foreach (@packages2update) {
440 print FH $_."\n";
441 }
442 close(FH);
443 print_ok("done!\n\n");
444 }
445
446 # - Any packages not found? Do we need additional entries in up2date_package.altname? >
447 if ($#need_packagealtname >= 0) {
448 print_info("".($#need_packagealtname+1)." packages were found where a up2date_package.altname entry is missing or wrong:\n");
449 foreach (@need_packagealtname) {
450 print " - ".$_."\n";
451 }
452 print " Please add entries for these packages to the up2date_package.altname file.\n";
453 }
454
455 print "\n";
456 exit(0);
457
458 # -----------------------------------------------------------------------------
459 # subs >
460 # -----------------------------------------------------------------------------
461
462 sub getPerlPackages {
463 my %excludeDirs = ("." => 1, ".." => 1, "metadata" => 1, "licenses" => 1, "eclass" => 1, "distfiles" => 1, "virtual" => 1, "profiles" => 1);
464 my @matches = ();
465 my $dhp;
466 my $tc;
467 my $tp;
468
469 foreach $tc (@scan_portage_categories) {
470 $dhp = new DirHandle($portdir."/".$tc);
471 while (defined($tp = $dhp->read)) {
472 # - not excluded and $_ is a dir?
473 if (! $excludeDirs{$tp} && -d $portdir."/".$tc."/".$tp) {
474 @tmp_availableVersions=();
475 my @tmp_availableEbuilds = getAvailableEbuilds($portdir,$tc."/".$tp);
476 foreach (@tmp_availableEbuilds) {
477 push(@tmp_availableVersions,getEbuildVersion($_));
478 }
479
480 # - get highest version >
481 if ($#tmp_availableVersions>-1) {
482 $modules{'portage_lc_realversion'}{lc($tp)}=(sort(@tmp_availableVersions))[$#tmp_availableVersions];
483 $modules{'portage_lc'}{lc($tp)}=$modules{'portage_lc_realversion'}{lc($tp)};
484
485 # - get rid of -rX >
486 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)-r[0-9+]/$1/;
487 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)-rc[0-9+]/$1/;
488 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)_p[0-9+]/$1/;
489 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)_pre[0-9+]/$1/;
490
491 # - get rid of other stuff we don't want >
492 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)_alpha[0-9+]?/$1/;
493 $modules{'portage_lc'}{lc($tp)}=~s/([a-zA-Z0-9\-_\/]+)_beta[0-9+]?/$1/;
494 $modules{'portage_lc'}{lc($tp)}=~s/[a-zA-Z]+$//;
495
496 $modules{'portage'}{lc($tp)}{'name'}=$tp;
497 $modules{'portage'}{lc($tp)}{'category'}=$tc;
498 }
499 }
500 }
501 undef $dhp;
502 }
503 }
504
505 # Description:
506 # Returns the value of $param. Expects filecontents in $file.
507 # $valueOfKey = getParamFromFile($filecontents,$key);
508 # e.g.
509 # $valueOfKey = getParamFromFile(getFileContents("/path/to.ebuild","IUSE","firstseen");
510 sub getParamFromFile {
511 my $file = shift;
512 my $param = shift;
513 my $mode = shift; # ("firstseen","lastseen") - default is "lastseen"
514 my $c = 0;
515 my $d = 0;
516 my @lines = ();
517 my @aTmp = (); # temp (a)rray
518 my $sTmp = ""; # temp (s)calar
519 my $text = ""; # complete text/file after being cleaned up and striped
520 my $value = ""; # value of $param
521 my $this = "";
522
523 # - 1. split file in lines >
524 @lines = split(/\n/,$file);
525
526 # - 2 & 3 >
527 for($c=0;$c<=$#lines;$c++) {
528 # - 2. remove leading and trailing whitespaces and tabs from every line >
529 $lines[$c]=~s/^[ |\t]+//; # leading whitespaces and tabs
530 $lines[$c]=~s/[ |\t]+$//; # trailing whitespaces and tabs
531
532 # - 3. remove comments >
533 $lines[$c]=~s/#(.*)//g;
534
535 if ($lines[$c]=~/^$param="(.*)"/) {
536 # single-line with quotationmarks >
537 $value=$1;
538
539 if ($mode eq "firstseen") {
540 # - 6. clean up value >
541 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
542 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
543 $value=~s/\t/ /g; # replace tabs with whitespaces
544 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
545 return $value;
546 }
547 }
548 elsif ($lines[$c]=~/^$param="(.*)/) {
549 # multi-line with quotationmarks >
550 $value=$1." ";
551 for($d=$c+1;$d<=$#lines;$d++) {
552 # - look for quotationmark >
553 if ($lines[$d]=~/(.*)"/) {
554 # - found quotationmark; append contents and leave loop >
555 $value.=$1;
556 last;
557 }
558 else {
559 # - no quotationmark found; append line contents to $value >
560 $value.=$lines[$d]." ";
561 }
562 }
563
564 if ($mode eq "firstseen") {
565 # - 6. clean up value >
566 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
567 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
568 $value=~s/\t/ /g; # replace tabs with whitespaces
569 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
570 return $value;
571 }
572 }
573 elsif ($lines[$c]=~/^$param=(.*)/) {
574 # - single-line without quotationmarks >
575 $value=$1;
576
577 if ($mode eq "firstseen") {
578 # - 6. clean up value >
579 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
580 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
581 $value=~s/\t/ /g; # replace tabs with whitespaces
582 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
583 return $value;
584 }
585 }
586 }
587
588 # - 6. clean up value >
589 $value=~s/^[ |\t]+//; # remove leading whitespaces and tabs
590 $value=~s/[ |\t]+$//; # remove trailing whitespaces and tabs
591 $value=~s/\t/ /g; # replace tabs with whitespaces
592 $value=~s/ {2,}/ /g; # replace 1+ whitespaces with 1 whitespace
593
594 return $value;
595 }
596
597 # Description:
598 # Returnvalue is the content of the given file.
599 # $filecontent = getFileContents($file);
600 sub getFileContents {
601 my $content = "";
602 open(FH,"<".$_[0]) || die("Cannot open file ".$_[0]);
603 $content = do{local $/; <FH>};
604 close(FH);
605 return $content;
606 }
607
608 # Description:
609 # @listOfEbuilds = getAvailableEbuilds($PORTDIR, category/packagename);
610 sub getAvailableEbuilds {
611 my $PORTDIR = shift;
612 my $catPackage = shift;
613 my @packagelist = ();
614
615 if (-e $PORTDIR."/".$catPackage) {
616 # - get list of ebuilds >
617 my $dh = new DirHandle($PORTDIR."/".$catPackage);
618 while (defined($_ = $dh->read)) {
619 if ($_ =~ m/(.+)\.ebuild$/) {
620 push(@packagelist,$_);
621 }
622 }
623 }
624
625 return @packagelist;
626 }
627
628 # Description:
629 # Returns version of an ebuild.
630 # $version = getEbuildVersion("foo-1.23-r1.ebuild");
631 sub getEbuildVersion {
632 my $version = shift;
633 $version =~ s/\.ebuild$//;
634 $version =~ s/^([a-zA-Z0-9\-_\/\+]*)-([0-9\.]+[a-zA-Z]?)/$2/;
635 return $version;
636 }
637
638 sub getCPANPackages {
639 my $force_cpan_reload = shift;
640 my $cpan_pn = "";
641 my @tmp_v = ();
642
643 if ($force_cpan_reload) {
644 # - User forced reload of the CPAN index >
645 CPAN::Index->force_reload();
646 }
647
648 for $mod (CPAN::Shell->expand("Module","/./")) {
649 if (defined $mod->cpan_version) {
650 # - Fetch CPAN-filename and cut out the filename of the tarball.
651 # We are not using $mod->id here because doing so would end up
652 # missing a lot of our ebuilds/packages >
653 $cpan_pn = $mod->cpan_file;
654 $cpan_pn =~ s|.*/||;
655
656 if ($mod->cpan_version eq "undef" && ($cpan_pn=~m/ / || $cpan_pn eq "" || ! $cpan_pn )) {
657 # - invalid line - skip that one >
658 next;
659 }
660
661 # - Right now both are "MODULE-FOO-VERSION-EXT" >
662 my $cpan_version = $cpan_pn;
663
664 # - Drop "-VERSION-EXT" from cpan_pn >
665 $cpan_pn =~ s/(?:-?)?(?:v?[\d\.]+[a-z]?)?\.(?:tar|tgz|zip|bz2|gz|tar\.gz)?$//;
666
667 if ( length(lc($cpan_version)) >= length(lc($cpan_pn)) ) {
668 # - Drop "MODULE-FOO-" from version >
669 if (length(lc($cpan_version)) == length(lc($cpan_pn))) {
670 $cpan_version=0;
671 }
672 else {
673 $cpan_version = substr($cpan_version,length(lc($cpan_pn))+1,length(lc($cpan_version))-length(lc($cpan_pn))-1);
674 }
675 if (defined $cpan_version) {
676 $cpan_version =~ s/\.(?:tar|tgz|zip|bz2|gz|tar\.gz)?$//;
677
678 # - Remove any leading/trailing stuff (like "v" in "v5.2.0") we don't want >
679 $cpan_version=~s/^[a-zA-Z]+//;
680 $cpan_version=~s/[a-zA-Z]+$//;
681
682 # - Convert CPAN version >
683 @tmp_v=split(/\./,$cpan_version);
684 if ($#tmp_v > 1) {
685 if ($DEBUG) { print " converting version -> ".$cpan_version; }
686 $cpan_version=$tmp_v[0].".";
687 for (1..$#tmp_v) { $cpan_version.= $tmp_v[$_]; }
688 if ($DEBUG) { print " -> ".$cpan_version."\n"; }
689 }
690
691 if ($cpan_version eq "") { $cpan_version=0; }
692
693 $modules{'cpan'}{$cpan_pn} = $cpan_version;
694 $modules{'cpan_lc'}{lc($cpan_pn)} = $cpan_version;
695 }
696 }
697 }
698 }
699 return 0;
700 }
701
702 sub getPortdir {
703 return getParamFromFile(getFileContents("/etc/make.globals").getFileContents("/etc/make.conf"),"PORTDIR","lastseen");
704 }
705
706 sub printHeader {
707 print "\n".color("green bold")." up2date-ng".color("reset")." version ".$VERSION." - brought to you by the Gentoo perl-herd-maintainer ;-)\n";
708 print " Distributed under the terms of the GPL-2\n\n";
709 }
710
711 sub printUsage {
712 print " --generate-xml : generate GuideXML file with table of outdated packages\n";
713 print " (using template_outdated-cpan-packages.xml)\n";
714 print " --generate-mail : generate an mail body\n";
715 print " (using template_outdated-cpan-packages.mail)\n";
716 print " --generate-html : generate html file with table of outdated packages\n";
717 print " (using template_outdated-cpan-packages.html)\n";
718 print " --generate-packagelist : generate list of outdated packages\n";
719 print " --generate-all : enables generation on xml, mail, html and packagelist\n";
720 print " --force-cpan-reload : forces reload of the CPAN indexes\n";
721 print " --portdir : use given PORTDIR instead of the one defined in make.conf\n";
722 print " --debug : show debug information\n";
723 print " -h, --help : show this help\n";
724 print "\n";
725
726 return 0;
727 }
728
729 # Description:
730 # Prints gentoo-style items.
731 sub printColored {
732 print ' ' . color(shift) . '* ' . color("reset") . shift() , @_;
733 }
734
735 # Description:
736 # Wrapper for printColored >
737 sub print_ok {
738 printColored('green bold',shift);
739 }
740
741 # Description:
742 # Wrapper for printColored >
743 sub print_err {
744 printColored('red bold',shift);
745 }
746
747 # Description:
748 # Wrapper for printColored >
749 sub print_info {
750 printColored('yellow bold',shift);
751 }
752
753 # - Here comes the POD >
754
755 =head1 NAME
756
757 up2date-ng - Compare module versions (ebuild vs CPAN)
758
759 =head1 VERSION
760
761 This document refers to version 0.22 of up2date-ng
762
763 =head1 SYNOPSIS
764
765 up2date-ng [option]...
766
767 =head1 DESCRIPTION
768
769 up2date-ng is a tool that compares the versions of perl packages in portage
770 with the version of the packages on CPAN. up2date-ng is developed and used
771 by the Gentoo perl-herd maintainers to keep track of which cpan related
772 ebuilds could be versionbumped.
773
774 =head1 AGRUMENTS
775
776 --generate-xml generate GuideXML file with table of outdated packages
777 (using template_outdated-cpan-packages.xml)
778
779 --generate-mail generate an mail body
780 (using template_outdated-cpan-packages.mail)
781
782 --generate-html generate html file with table of outdated packages
783 (using template_outdated-cpan-packages.html)
784
785 --generate-packagelist generate list of outdated packages
786
787 --generate-all enables generation on xml, mail, html and packagelist
788
789 --force-cpan-reload forces reload of the CPAN indexes
790
791 --portdir use given PORTDIR instead of the one defined in make.conf
792
793 --debug show debug information
794
795 -h, --help show options and versionnumber
796
797 =head1 AUTHOR
798
799 Christian Hartmann <ian@gentoo.org>
800
801 =head1 TODO
802
803 Put your stuff here and poke me.
804
805 =head1 REPORTING BUGS
806
807 Please report bugs via http://bugs.gentoo.org/ or https://bugs.gentoo.org/
808
809 =head1 LICENSE
810
811 up2date-ng - Compare module versions (ebuild vs CPAN)
812 Copyright (C) 2006 Christian Hartmann
813
814 This program is free software; you can redistribute it and/or modify
815 it under the terms of the GNU General Public License as published by
816 the Free Software Foundation; either version 2 of the License, or
817 (at your option) any later version.
818
819 This program is distributed in the hope that it will be useful,
820 but WITHOUT ANY WARRANTY; without even the implied warranty of
821 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
822 GNU General Public License for more details.
823
824 You should have received a copy of the GNU General Public License
825 along with this program; if not, write to the Free Software
826 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
827
828 =cut

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.20