#!/usr/freeware/bin/perl -w
# -*- Perl -*-
# Copyright 2002 Silicon Graphics, Inc. All rights reserved.
# $Id: prereq.cgi,v 1.2 2006/07/21 20:58:06 dkascht Exp $
#
# Render prereq.txt in a more readable per-package form.
# Thanks to Andrea Suatoni for the inspiration, and
# Jeff Hanson for the help and refinements.
#
# Possible extensions:
#  o Rework prereq.txt to include full per-subsys prereq data.
#  o Parse "versions -bn fw\*" output and prune existing packages.
#  o Generate a cut&paste list of download commands.
#  o Make it usable locally (off-line), rather than only from 
#    freeware.sgi.com.

use strict;
use CGI;
use CGI::Carp;

# Hash tables entries are sets (hashes) of package names.
my %PREREQS;
my %USED_BY;

# Set of all known products, indexed by real name.
my %PRODUCTS;

# Mapping for updates rules
my %UPDATES;
my %MAP;

# Decode name mangling in prereq.txt
my %DEMANGLE;
my $known_demangling = 0;

my $datafile = "prereq.txt";
my $mapfile = "name-map.txt";
my $template = "shared/index.template";

# General setup -- parse the query parameters.
my $query = new CGI;
my $product = $query->param('product');
my $display = $query->param('display');

# Assume some default values (recursive).
$display = '' if (!defined $display);

my $recursive = $display ne "direct";
my $flat = $display ne "nested";

# Load the name-map file.
&load_map($mapfile);

# Load the prereq data file.
my $title = &load_data($datafile);
my $title_ext = "";
if (defined $product && $product ne "") {
    $title_ext = "$product";
    if ($display) {
	$title_ext .= " ($display)";
    }
}

# Output some header information.
print $query->header;


# Assemble the title section.
my $full_title = $title_ext ? "SGI IRIX Freeware Dependencies: " . $title_ext : $title;
my $TITLE = 
    join("\n",
	 "<TITLE>$full_title</TITLE>",
	 '<META NAME="keywords"    CONTENT="SGI, IRIX, freeware, shareware, GNU, Linux">',
	 '<META NAME="description" CONTENT="Freeware packages pre-built for IRIX 6.5">',
	 '<META NAME="owner"       CONTENT="freeware@sgi.com">');


# Assemble the contents section.
my $CONTENTS = join("\n", $query->h1($title . ($title_ext ? ":\n<BR>\n" . $title_ext : "")), "");

# Output the form.
my @products = sort keys %PRODUCTS;
$CONTENTS .= 
    join("\n", 
	 $query->hr, "",
	 $query->start_form(-action => $query->self_url, -method=>"GET"),
	 $query->p("Freeware product: ",
		   $query->popup_menu(-name   => 'product', 
				      -values => \@products),
		   "<br>Show references: ", 
		   $query->popup_menu(-name    => 'display', 
				      -values  => [ 'recursive', 'nested', 'direct' ],
				      -default => 'recursive',
				      -labels  => { 'direct' => 'immediate dependencies only',
						    'nested' => 'hierarchically, without duplicates',
						    'recursive' => 'all dependencies' })),
	 $query->submit,
	 $query->end_form,
	 "");

# Output some boilerplate.
$CONTENTS .= 
    join("\n", 
	 $query->p("<b>Note</b>: the output considers all possible
dependencies, including those from non-default and mutually incompatible
subsystems, as well as alternative prereqs.  Your actual requirements
may be less depending on which subsystems you choose to install.  Also
this output ignores version numbers, so although you may have all the
listed required packages installed, you might still get conflicts from
the software manager if your packages are out of date.\n"),
	 $query->p("See the",
		   $query->a({href=>"selections.html"}, 
			     "Freeware Selections Files"),
		   "\n",
		   "web page for more information.\nRaw data is in",
		   $query->a({href=>$datafile}, $datafile)));

# Output the query result
if (not defined $product) {
    # No query was made.
} elsif ($product && not exists $PRODUCTS{$product}) {
    $CONTENTS .= 
	join("\n", 
	     $query->hr,
	     "<h2>Package '$product' is unknown.</h2>");
} else {
    $CONTENTS .= 
	join("\n", 
	     $query->hr,
	     "<h2>Package $product requires:</h2>\n");
    $CONTENTS .= show_deps($product, \%PREREQS);
    $CONTENTS .= 
	join("\n", 
	     $query->p,
	     "<h2>Package $product is required by:</h2>\n");
    $CONTENTS .= show_deps($product, \%USED_BY);
}


# Load the entire template.
open(TEMPLATE, "<$template") || die("Unable to open $template: $!\n");
my $output = join("", <TEMPLATE>);
close(TEMPLATE);

# Customize the template.
$output =~ s/(\<!-- BEGIN TITLE --\>).*?(\<!-- END TITLE --\>)/$1\n$TITLE\n$2/gms;
$output =~ s/(\<!-- BEGIN HIGHLIGHTS --\>).*?(\<!-- END HIGHLIGHTS --\>)/$1\n$2/gms;
# Leave SIDENAV in place.
$output =~ s/(\<!-- BEGIN CONTENTS --\>).*?(\<!-- END CONTENTS --\>)/$1\n$CONTENTS\n$2/gms;
$output =~ s/(\<!-- BEGIN INSTALLED INDEX --\>).*?(\<!-- END INSTALLED INDEX --\>)/$1\n$2/gms;
# Leave INSTALLABLE INDEX in place.
$output =~ s/(\<!-- BEGIN HTTPLINKS --\>).*?(\<!-- END HTTPLINKS --\>)/$1\n$2/gms;
# Leave FILELINKS in place.

# And emit the finished product...
print $output;

exit 0;

# ------------------------------------------------------------

# The prereq.txt files have slightly mangled names.  Try to fix them.
sub demangle
{
    ($_) = @_;

    if (exists $DEMANGLE{$_}) {
	return $DEMANGLE{$_};
    } elsif ($known_demangling) {
	return $_;
    } else {
	# Until Nov 2002 prereq files didn't document mangling,
	# so take a guess if we don't know for sure.
	my $orig = $_;

	s/PLUS/+/g;
	s/_/-/g;
	s/fw-/fw_/;

	# Fix some special cases.
	s/fw_mod-ssl/fw_mod_ssl/;
	s/fw_tcp-wrappers/fw_tcp_wrappers/;
	s/fw_pam-ldap-auth/fw_pam_ldap_auth/;
	s/fw_pam-radius-auth/fw_pam_radius_auth/;

	# Remember this result.
	$DEMANGLE{$orig} = $_;

	return $_;
    }
}

# ------------------------------------------------------------

sub load_map
{
    # Usage: &load_map("filename");
    my ($mapfile) = @_;
    my ($image);
    
    # Load all the name mapping data.
    open(DATA, "<$mapfile") || die("Unable to open $mapfile: $!\n");
    while(<DATA>) {
	chomp;
	next if (/^\#/);

	($image) = (split(/,/))[1];
	$MAP{$image} = $_;
    }

    close(DATA);
}

# ------------------------------------------------------------

sub load_data
{
    # Usage: $release = &load_data("filename");
    my ($datafile) = @_;
    my $label;
    my $prod;
    my $dep;

    # Parse all the prereq information from prereq.txt.
    open(DATA, "<$datafile") || die("Unable to open $datafile: $!\n");
    while(<DATA>) {
	chomp;

	# Save name mangling information.
	if (/^\#\tReplace (\S+) with (\S+)\s*$/) {
	    # Assume that if we know any demangled names we know them all.
	    $known_demangling++;
	    $DEMANGLE{$2} = $1;
	    next;
	}

	# Grab the label when it goes by.
	if (/^\tlabel = "(.*)";\s*$/) {
	    $label = $1;
	    next;
	}

	# Real dependency lines have the form "\tfoo -> bar".
	if (/^\t(\S+) -> (\S+)\s*$/) {
	    $prod = &demangle($1);
	    $dep = &demangle($2);
	    $PREREQS{$prod}{$dep} = 1;
	    $USED_BY{$dep}{$prod} = 1;
	    $PRODUCTS{$prod} = 1;
	    next;
	}

	# Updates look like "\tfoo -> bar [style=dotted]"
	if (/^\t(\S+) -> (\S+) \[style=dotted\]\s*$/) {
	    $UPDATES{&demangle($1)} = &demangle($2);
	    next;
	}

	# Stand-alone packages look like "\t\tfoo -> bar -> bas ...;"
	if (/^\t\t(\S+ -> .*);\s*$/) {
	    foreach (split / -> /, $1) {
		$prod = &demangle($_);
		$PRODUCTS{$prod} = 1;
	    }
	    next;
	}

	# Producers look like "\tfoo [ shape=box,peripheries=2 ]"
	if (/^\t(\S+) \[ shape=box,peripheries=2 \]\s*$/) {
	    $prod = &demangle($1);
	    $PRODUCTS{$prod} = 1;
	    next;
	}
    }
    close(DATA);

    return $label;
}

# ------------------------------------------------------------

sub prod_ref
{
    # Given a package name return a reference for it.  This isn't
    # trivial because the registry product name, spec file product,
    # and source tree path don't always agree.
    my ($prod) = @_;
    my ($item) = $prod;

    # Handle updated packages.
    if (exists $UPDATES{$prod} && not exists $PRODUCTS{$prod}) {
	$prod = $UPDATES{$prod};
	$item .= "&nbsp;($prod)";
    }

    # Use known mapping info when possible.
    if (exists $MAP{$prod}) {
	my ($registry, $image, $ref, $relnotes, $tardist) = split(/,/, $MAP{$prod});

	my $enc_prod = $prod;
	$enc_prod =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;

	my $query_url = $query->self_url();
	if ($query_url !~ s/(.)product=[^&]*/$1product=$enc_prod/) {
	    $query_url .= (($query_url =~ /&/) ? '&' : '?') . "product=$enc_prod";
	}

	return "$item" .
	       "&nbsp;<a href=\"$relnotes\">[relnotes]</a>" .
	       "&nbsp;<a href=\"$query_url\">[prereqs]</a>" .
	       "&nbsp;<a href=\"$tardist\">[install]</a>";
    }

    # We have no idea what's going on.  Do something.
    return "$item";
}

sub show_deps
{
    my ($prod, $hashref) = @_;
    my %done;
    my $depth = 0;
    my $result = "";

    $done{$product} = 1;
    $result .= &show_deps_recursive($prod, $hashref, 0, \%done);

    if (keys %done == 1) {
	$result .= "<ul>\n<li><i>No other freeware packages</i>\n</ul>\n";
    } elsif ($flat) {
	$result .= "<ul>\n";
	foreach (sort keys %done) {
	    $result .= "<li>" . &prod_ref($_) . "\n" unless ($_ eq $prod);
	}
	$result .= "</ul>\n";
    }

    return $result;
}

sub show_deps_recursive
{
    my ($prod, $hashref, $depth, $doneref) = @_;
    my $dep;
    my $result = "";

    if (exists $hashref->{$prod}) {
	$result .= " " x ($depth * 2) . "<ul>\n" unless ($flat);
	foreach $dep (sort keys %{ $hashref->{$prod} }) {
	    next if $doneref->{$dep}++;
	    $result .= " " x ($depth * 2) . "<li>" . &prod_ref($dep) . "\n" unless ($flat);
	    $result .= show_deps_recursive($dep, $hashref, $depth + 1, $doneref) if ($recursive);
	}
	$result .= " " x ($depth * 2) . "</ul>\n" unless ($flat);
    }

    return $result;
}