#!/usr/bin/perl -w
#-
# Copyright (c) 2003 Dag-Erling Coïdan Smørgrav
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer
#    in this position and unchanged.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# $Id$
#

use strict;
use Getopt::Long;

sub PATH_MAKE		{ "/usr/bin/make" }

my $capture;			# Capture output
my $verbose   = 0;		# Verbose mode

#
# Shortcut for 'print STDERR'
#
sub stderr(@) {
    print(STDERR @_);
}

#
# Similar to err(3)
#
sub bsd::err($$@) {
    my $code = shift;		# Return code
    my $fmt = shift;		# Format string
    my @args = @_;		# Arguments

    my $msg;			# Error message

    $msg = sprintf($fmt, @args);
    stderr("$msg: $!\n");
    exit($code);
}

#
# Similar to errx(3)
#
sub bsd::errx($$@) {
    my $code = shift;		# Return code
    my $fmt = shift;		# Format string
    my @args = @_;		# Arguments

    my $msg;			# Error message

    $msg = sprintf($fmt, @args);
    stderr("$msg\n");
    exit($code);
}

#
# Similar to warn(3)
#
sub bsd::warn($@) {
    my $fmt = shift;		# Format string
    my @args = @_;		# Arguments

    my $msg;			# Error message

    $msg = sprintf($fmt, @args);
    stderr("$msg: $!\n");
}

#
# Similar to warnx(3)
#
sub bsd::warnx($@) {
    my $fmt = shift;		# Format string
    my @args = @_;		# Arguments

    my $msg;			# Error message

    $msg = sprintf($fmt, @args);
    stderr("$msg\n");
}

#
# Call the specified sub with $capture set
#
sub capture($@) {
    my $subr = shift;		# Subroutine to call
    my @args = @_;		# Arguments

    my $oldcapture;		# Old capture flag
    my $rtn;			# Return value

    $oldcapture = $capture;
    $capture = 1;
    $rtn = &{$subr}(@args);
    $capture = $oldcapture;
    return $rtn;
}

#
# Print an info message
#
sub info(@) {

    my $msg;			# Message

    if ($verbose) {
	$msg = join(' ', @_);
	chomp($msg);
	stderr("$msg\n");
    }
}

#
# Print an info message about a subprocess
#
sub cmdinfo(@) {
    info(">>>", @_);
}

#
# Change working directory
#
sub cd($) {
    my $dir = shift;		# Directory to change to

    cmdinfo("cd $dir");
    chdir($dir)
	or bsd::err(1, "unable to chdir to %s", $dir);
}

#
# Run a command and return its output
#
sub cmd($@) {
    my $cmd = shift;		# Command to run
    my @args = @_;		# Arguments

    my $pid;			# Child pid
    local *PIPE;		# Pipe
    my $output;			# Output
    my $rtn;			# Return value

    cmdinfo(join(" ", $cmd, @args));
    $pid = ($capture || $verbose) ? open(PIPE, "-|") : fork();
    if (!defined($pid)) {
	bsd::err(1, ($capture || $verbose) ? "open()" : "fork()");
    } elsif ($pid == 0) {
	exec($cmd, @args);
	die("child: exec(): $!\n");
    }
    if ($capture || $verbose) {
	$output = "";
	while (<PIPE>) {
	    $output .= $_;
	    if ($verbose) {
		stderr($_);
	    }
	}
    }
    $rtn = ($capture || $verbose) ? close(PIPE) : (waitpid($pid, 0) == $pid);
    if (!$rtn) {
	if ($? & 0xff) {
	    bsd::warnx("%s caught signal %d", $cmd, $? & 0x7f);
	} elsif ($? >> 8) {
	    bsd::warnx("%s returned exit code %d", $cmd, $? >> 8);
	} else {
	    bsd::warn("close()");
	}
	return undef;
    }
    if ($capture) {
	$output =~ s/\n*$//s;
	return $output;
    }
    return 1;
}

#
# Run make
#
sub make(@) {
    my @args = @_;

    return cmd(&PATH_MAKE, @args);
}

sub scuttle() {

    exit(1);
}

sub usage() {

    print(STDERR "usage: $0 <dir>\n");
    exit(1);
}

my @worklist;
my @modules;
my %maintainer;

MAIN:{
    my $root;
    my $subdirs;

    Getopt::Long::Configure("auto_abbrev", "bundling");
    GetOptions(
	       "v|verbose"		=> \$verbose,
	       )
	or usage();
    usage()
	unless (@ARGV == 1);
    $root = $ARGV[0];
    cd($root)
	or scuttle();

    # Find userland modules
    defined($subdirs = capture(\&make, "-fMakefile.inc1", "-VSUBDIR"))
	or scuttle();
    @worklist = split(' ', $subdirs);
    while (@worklist) {
	my $dir = shift(@worklist);
	print(STDERR "$dir        \r");
	cd("$root/$dir")
	    or scuttle();
	defined($subdirs = capture(\&make, "-VSUBDIR"))
	    or scuttle();
	if ($subdirs =~ m/\S/) {
	    foreach my $subdir (split(' ', $subdirs)) {
		if ($dir =~ m/(bin|doc|man)$/) {
		    push(@modules, "$dir/$subdir");
		} else {
		    push(@worklist, "$dir/$subdir");
		}
	    }
	} else {
	    push(@modules, $dir);
	}
    }

    # Determine maintainership
    foreach my $module (@modules) {
	print(STDERR "$module        \r");
	cd("$root/$module")
	    or scuttle();
	my $maintainer;
	defined($maintainer = capture(\&make, "-VMAINTAINER"))
	    or scuttle();
	next if ($maintainer !~ m/\S/);
	$maintainer =~ s/^\s*(.*?)\s*$/$1/;
	$maintainer =~ s/\@freebsd\.org//gi;
	$maintainer{$module} = $maintainer;
    }

    print(STDERR "Done scanning source tree                \n");

    foreach my $module (sort(@modules)) {
	print($module);
	if ($maintainer{$module}) {
	    print(" ($maintainer{$module})");
	}
	print("\n");
    }
}