openbsd-ports/infrastructure/build/out-of-date

#!/usr/bin/perl

# $OpenBSD: out-of-date,v 1.16 2007/06/01 15:01:50 espie Exp $
#
# Copyright (c) 2005 Bernd Ahlers <bernd@openbsd.org>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use strict;
use warnings;
use OpenBSD::Getopt;
use OpenBSD::Error;
use OpenBSD::PackageInfo;
use OpenBSD::PackingList;
use OpenBSD::PackageName;
use OpenBSD::ProgressMeter;
use File::Temp;

our $opt_q;
set_usage('out-of-date [-q]');
try {
	getopts('q');
} catchall {
	Usage($_);
};

sub collect_installed
{
	my $pkg = {};
	for my $name (installed_packages(1)) {
		my ($stem, $version) = OpenBSD::PackageName::splitname($name);
		my $plist = OpenBSD::PackingList->from_installation($name,
		    \&OpenBSD::PackingList::UpdateInfoOnly);
		if (!defined $plist or !defined $plist->{extrainfo}->{subdir}) {
			print STDERR "Package $name has no valid packing-list\n";
			next;
		}
			
		my $subdir = $plist->{extrainfo}->{subdir};
		$subdir =~ s/mystuff\///;
		$subdir =~ s/\/usr\/ports\///;

		$pkg->{$subdir}->{name}	     = $name;
		$pkg->{$subdir}->{stem}      = $stem;
		$pkg->{$subdir}->{version}   = $version;
		$pkg->{$subdir}->{signature} = $plist->signature();
	}
	return $pkg;
}

sub fh_open
{
	open(my $fh, shift);
	my $old = select $fh;
	$| = 1;
	select STDERR;
	return $fh, $old;
}

sub fh_close
{
	my ($fh, $old) = @_;
	close($fh);
	select $old;
}

sub collect_port_versions
{
	my ($pkg, $portsdir, $notfound) = @_;

	my @subdirs = ();
	for my $subdir (keys %$pkg) {
		my ($dir) = split(/,/, $subdir);
		if (-d "$portsdir/$dir") {
			push(@subdirs, $subdir);
		} else {
			push(@$notfound, $subdir);
		}
	}

	my $cmd = "cd $portsdir && SUBDIR=\"".join(' ', @subdirs)
	    ."\" REPORT_PROBLEM=true make ".'show=FULLPKGNAME\${SUBPACKAGE} '
	    ."2>&1 |";

	my $port  = {};
	my $error = {};
	my $count = 0;
	my $total = scalar @subdirs;

	my $progress = OpenBSD::ProgressMeter->new;
	$progress->set_header("Collecting port versions");
	my ($fh, $old) = fh_open($cmd);
	my $subdir     = "";
	while (<$fh>) {
		chomp;
		if (/^\=\=\=\>\s+(\S+)/) {
			$subdir = $1;
			$count++;
			$progress->show($count, $total);
			next;
		}
		next unless $_ or $subdir;
		next if defined $error->{$subdir};
		if (/^(Fatal\:|\s+\()/) {
			push(@{$error->{$subdir}}, $_);
			next;
		} elsif (/^(Stop|\*\*\*)/) {
			next;
		}
		$port->{$subdir}->{name} = $_;
		my ($stem, $version) = OpenBSD::PackageName::splitname($_);
		$port->{$subdir}->{stem}    = $stem;
		$port->{$subdir}->{version} = $version;
	}
	fh_close($fh, $old);
	$progress->next;

	return $port, $error;
}

sub collect_port_signatures
{
	my $pkg      = shift;
	my $port     = shift;
	my $portsdir = shift;
	my $output   = shift;

	my @subdirs = ();
	for my $dir (keys %$port) {
		if ($pkg->{$dir}->{name} eq $port->{$dir}->{name}) {
			push(@subdirs, $dir);
		}
	}

	my $TMPDIR = $ENV{'TMPDIR'} || "/tmp";
	my $tempdir = File::Temp::tempdir("libcache.XXXXXXX", DIR => $TMPDIR, CLEANUP => 1);
	$ENV{'_DEPENDS_CACHE'} = "$tempdir/depends_cache";
	$ENV{'_DEPENDS_FILE'} = "$tempdir/depends_file";
	$ENV{'_PORT_LIBS_CACHE'} = $tempdir;
	open(my $touch, '>', "$tempdir/depends_file");
	close($touch);
	my $cmd = "cd $portsdir && SUBDIR=\"".join(' ', @subdirs)
	    ."\" REPORT_PROBLEM=true make print-package-signature |";

	my $count = 0;
	my $total = scalar @subdirs;
	my $progress = OpenBSD::ProgressMeter->new;
	$progress->set_header("Collecting port signatures");
	my ($fh, $old) = fh_open($cmd);
	my $subdir     = "";
	while (<$fh>) {
		chomp;
		if (/^\=\=\=\>\s+(\S+)/) {
			$subdir = $1;
			$count++;
			$progress->show($count, $total);
			next;
		}
		next unless $_ or $subdir;
		$port->{$subdir}->{signature} = $_;
	}
	fh_close($fh, $old);
	$progress->next;
}

sub split_sig
{
	my $sig = shift;
	my $ret = {};

	for my $item (split(/,/, $sig)) {
		$ret->{$item} = 1;
	}

	return $ret;
}

sub diff_sig
{
	my ($dir, $pkg, $port) = @_;

	my $old	= split_sig($pkg->{$dir}->{signature});
	my $new	= split_sig($port->{$dir}->{signature});

	for my $key (keys %$old) {
		if (defined $new->{$key}) {
			delete $old->{$key};
			delete $new->{$key};
		}
	}

	return join(',', sort keys %$old), join(',', sort keys %$new);
}

sub find_outdated
{
	my ($pkg, $port, $output) = @_;

	for my $dir (keys %$pkg) {
		next unless $port->{$dir};
		if ($pkg->{$dir}->{name} ne $port->{$dir}->{name}) {
			push(@$output, sprintf("%-30s # %s -> %s\n", $dir,
			    $pkg->{$dir}->{version}, $port->{$dir}->{version}));
			next;
		}
		next if $opt_q;
		if ($pkg->{$dir}->{signature} ne $port->{$dir}->{signature}) {
			push(@$output, sprintf("%-30s # %s -> %s\n", $dir,
			    diff_sig($dir, $pkg, $port)));
		}
	}
}

my $portsdir = $ENV{PORTSDIR} || "/usr/ports";

print STDERR "Collecting installed packages\n";
my $pkg = collect_installed();

my @output   = ();
my @notfound = ();
my ($port, $errors) = collect_port_versions($pkg, $portsdir, \@notfound);

collect_port_signatures($pkg, $port, $portsdir, \@output) unless $opt_q;
find_outdated($pkg, $port, \@output);

print STDERR "Outdated ports:\n\n";
print $_ for sort @output;

if ($opt_q) {
	print STDERR "\nWARNING: You've used the -q option. With this,\n"
	    . "out-of-date only looks for changed package names\nbut not "
	    . "for changed package signatures. If you\nwant to see ALL "
	    . "of your outdated packages,\ndon't use -q.\n";
}

if (@notfound > 0) {
	print STDERR "\nPorts that can't be found in the official "
	    . "ports tree:\n";
	for (sort @notfound) {
		print STDERR "  $_\n";
	}
}
if ((keys %$errors) > 0) {
	print STDERR "\nErrors:\n";
	for (sort keys %$errors) {
		print STDERR "  $_\n";
		print STDERR "    $_\n" for @{$errors->{$_}};
	}
}