#!/usr/bin/perl

# perltest.pl - script to test the status of perl modules on a LON-CAPA system
#
# $Id: perltest.pl,v 1.12 2003/08/22 20:48:38 albertel Exp $
#
###

=pod

=head1 NAME

B<perltest.pl> - Test status of perl modules installed on a LON-CAPA system.

=cut

# Written to help LON-CAPA (The LearningOnline Network with CAPA)
#

=pod

=head1 SYNOPSIS

perl perltest.pl [MODE]

This script is located inside the LON-CAPA source code tree.
This script is invoked by test-related targets inside
F<loncapa/loncom/build/Makefile>.

This script is also used as a CGI script and is installed
at the file location of F</home/httpd/cgi-bin/perltest.pl>.

MODE, when left blank, the output defaults to 'statusreport' mode.
Except however, if $ENV{'QUERY_STRING'} exists, in which case
'html' mode is safely assumed.

Here is a complete list of MODEs.

=over 4

=item html

A web page detailing the status of CPAN distributions on a LON-CAPA server
(as well as methods for resolution).

=item synopsis

Plain-text output which just summarizes the status of
expected CPAN distributions on a system.  (This is what a
user sees when running the ./TEST command.)

=item statusreport

Plain-text output which provides a detailed status report of
CPAN distributions on a LON-CAPA server (as well as methods
for resolution).

=back

=head1 DESCRIPTION

This program tests the status of perl modules installed on a LON-CAPA system.
As with the other LON-CAPA test scripts, when reasonable, I try
to avoid importing functionality from other LON-CAPA modules so as to
avoid indirectly testing software dependencies.

=head2 ORGANIZATION OF THIS PERL SCRIPT

The script is organized into the following sections.

=over 4

=item 1.

Process version information of this file.

=item 2.

Determine output mode for the script.

=item 3.

Output header information.

=item 4.

Make sure the perl version is suitably high.

=item 5.

Make sure we have the find command.

=item 6.

Scan for all the perl modules present on the filesystem.

=item 7.

Read in cpan_distributions.txt.

=item 8.

Loop through all of the needed CPAN distributions and probe the system.

=item 9

Output a report (dependent on output mode).

=item 10

Subroutines.

B<vers_cmp> - compare two version numbers and see which is greater.

B<have_vers> - syntax check the version number and call B<vers_cmp>.

=back

=head1 STATUS

Ratings: 1=horrible 2=poor 3=fair 4=good 5=excellent

=over 4

=item Organization

5

=item Functionality

5

=item Has it been tested?

4

=back

=head1 AUTHOR

This software is distributed under the General Public License,
version 2, June 1991 (which is the same terms as LON-CAPA).

This is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This software is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this software; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

=cut

# =================================== Process version information of this file.
my $VERSION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);

# ========================== Determine the mode that this script should run in.
my $mode;
$mode=shift(@ARGV) if @ARGV;
unless ( $mode )
  {
    $mode = 'statusreport';
  }
if ( defined($ENV{'QUERY_STRING'}) )
  {
    $mode = 'html';
  }

# ================================================== Output header information.
my $hostname = `hostname`; chomp($hostname);
my $date = `date`; chomp($date);

# --- html mode blurb
if ($mode eq "html") {
    print(<<END);
Content-type: text/html

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8"></meta>
<title>CPAN perl status report; $hostname; $date</title>
</head>
<body bgcolor="white">
<h1>CPAN perl status report</h1>
<pre>
END
}

print('Running perltest.pl, version '.$VERSION.'.'."\n");
print('(Test status of perl modules installed on a LON-CAPA system).'."\n");

# This program is only a "modest" effort to LOOK and see whether
# necessary perl system dependencies are present.  I do not yet
# try to actually run tests against each needed perl module.
# Eventually, all modules will be version-checked, and reasonable
# testing implemented.

# ================================ Make sure the perl version is suitably high.
print('Checking version of perl'."\n");
print(`perl --version`);
unless (eval("require 5.005"))
  {
    die('**** ERROR **** DEPENDENCY FAILURE: require perl version >= 5.005.'.
	"\n".'Do you even have perl installed on your system?'."\n");
  }
else
  {
    print('Perl >= 5.005...okay'."\n");
  }

# ========================================= Make sure we have the find command.
my $ret = system("find --version 1>/dev/null");
if ($ret)
  {
    die('**** ERROR **** DEPENDENCY FAILURE: perltest.pl requires the GNU '.
	"'find'".' utility.'."\n");
  }
else
  {
    print('find command exists...okay'."\n");
  }

# ==================== Scan for all the perl modules present on the filesystem.
print('Scanning for perl modules...'."\n");
my $big_module_string; # All the modules glued together in a string.
my $number_of_modules = 0; # The total number of modules available in system.
# --- Build a pattern matching string.
foreach my $inc (@INC)
  {
    my @m = `find $inc -maxdepth 2000 -type f -name '*.pm'`;
    foreach my $module (@m)
      {
	$big_module_string .= $module;
	$number_of_modules++;
      }
  }
# --- Notify user of the number of modules.
print('There are '.$number_of_modules.
      ' perl modules present on your filesystem.'."\n");

my %dist_module_hash; # Relate the distributions to their VersionFrom modules.
my %module_name_on_filesystem; # Relate module name to filesystem syntax.
my %dist_dev_version_hash; # Expected development version of CPAN distribution.
my %dist_stable_version_hash; # Expected stable version of CPAN distribution.
my %module_dev_version_hash; # development version of versionfrom_module.
my %module_stable_version_hash; # stable version of versionfrom_module.

# ============================================= Read in cpan_distributions.txt.

# A brief description of CPAN (Comprehensive Perl Archive Network):
# CPAN software is not released as separate perl modules.
# CPAN software is released as "distributions" (also called "dists").
# Each distribution consists of multiple perl modules.
# For instance, the dist HTML-Tree (http://search.cpan.org/dist/HTML-Tree/)
# consists of the modules HTML::AsSubs, HTML::Element, HTML::Element::traverse,
# HTML::Parse, HTML::TreeBuilder, and HTML::Tree.
# Most (but not all) distributions have versions which are defined
# by one of their modules.  For the syntax of cpan_distributions.txt,
# please read the comments inside cpan_distributions.txt.

# Open cpan_distributions.txt.
open(IN,'<cpan_distributions.txt') or
    die('**** ERROR **** Cannot find cpan_distributions.txt'."\n");

while(<IN>) # Loop through the lines.
  {
    next if /^\#/; # Ignore commented lines.
    next unless /\S/; # Ignore blank lines.

    chomp; # Get rid of the newline at the end of the line.

    # Parse the line.
    my ($dist_name,$dist_dev_version,$dist_stable_version,$versionfrom_info) =
	split(/\s+/); # Parse apart the line fields.
    $versionfrom_info =~ /^(.*)\((.*)\)$/; # Parse apart the versionfrom info.
    my ($version_module,$version_match) = ($1,$2); # Parse vals into variables.

    # Calculate DevVersion and StableVersion for the VersionFrom module.
    my $module_dev_version;
    my $module_stable_version;
    if ($version_match eq "*") # There is a dist=module version relationship.
      {
	$module_dev_version = $dist_dev_version; # module=dist.
	$module_stable_version = $dist_stable_version; # module=dist.
      }
    else # There is not a dist=module version relationship.
      {
	($module_dev_version,$module_stable_version) = 
	    split(/\,/,$version_match); # module set to customized settings.
      }

    $dist_module_hash{$dist_name} = $version_module; # The big dist index.

    # What the module "looks like" on the filesystem.
    my $version_modulefs = $version_module;
    $version_modulefs =~ s!::!/!g; $version_modulefs.='.pm';
    $modulefs_hash{$version_module} = $version_modulefs;

    # Indexing the expected versions.
    $module_dev_version_hash{$version_module} = $module_dev_version;
    $module_stable_version_hash{$version_module} = $module_stable_version;
    $dist_dev_version_hash{$dist_name} = $dist_dev_version;
    $dist_stable_version_hash{$dist_name} = $dist_stable_version;
  }
close(IN);

# "MISSING"  means that no module is present inside the include path.
# "OUTDATED" means that a module is present inside the include path but is
#            an earlier version than expected.
# "VERYOKAY" means that the module version is an exact match for the expected
#            version.
# "OKAY"     means that the module version is more recent than the expected
#            version, so things are "probably" okay....  It is still possible
#            that LON-CAPA is incompatible with the newer distribution version
#            (corresponding to the module version).
my @dev_missing;
my @dev_outdated;
my @dev_okay;
my @dev_veryokay;
my @dev_to_update;
my @stable_missing;
my @stable_outdated;
my @stable_okay;
my @stable_veryokay;
my @stable_to_update;

# ===== Loop through all of the needed CPAN distributions and probe the system.
foreach my $dist (keys %dist_module_hash) {
    my $module = $dist_module_hash{$dist};
    my $fs = $modulefs_hash{$module};
    my $fsflag = 0;
    if ($big_module_string =~ /$fs/) { $fsflag = 1; }
    my ($vok,$vstr);
    foreach my $type ('dev','stable') {
	my ($vers_mod,$vers_dist);
	my ($missing,$outdated,$veryokay,$okay,$to_update);
	if ($type eq 'dev') {
	    $vers_mod=$module_dev_version_hash{$module};
	    $vers_dist=$dist_dev_version_hash{$dist};
	    ($missing,$outdated,$veryokay,$okay,$to_update)=
		(\@dev_missing,\@dev_outdated,\@dev_veryokay,\@dev_okay,
		 \@dev_to_update);
	} elsif ($type eq 'stable') {
	    $vers_mod=$module_stable_version_hash{$module};
	    $vers_dist=$dist_stable_version_hash{$dist};
	    ($missing,$outdated,$veryokay,$okay,$to_update)=
		(\@stable_missing,\@stable_outdated,\@stable_veryokay,
		 \@stable_okay,\@stable_to_update);
	}
	($vok,$vstr) = have_vers($module,$vers_mod);
	# print "fsflag: $fsflag, vok: $vok, vstr: $vstr, fs: $fs\n";
	if ($fsflag and !$vok and $vstr=~/not found/) {
	    push(@$missing,'MISSING  '.$dist.' (want distribution '.
		 $module.' version '. $vers_dist.') ?'."\n");
	    push(@$to_update,$dist);
	    # The question mark indicates there was a pattern match in the
	    # big_module_string which would be unexpected.
	    # There is no usual reason to tell the normal LON-CAPA user about this
	    # question mark.  This is just source code magic.
	} elsif (!$fsflag and !$vok and $vstr=~/not found/) {
	    push(@$missing,'MISSING  '.$dist.' (want distribution '.
		 $module.' version '.$vers_dist.')'."\n");
	    push(@$to_update,$dist);
	} elsif ($fsflag and !$vok and $vstr!~/not found/) {
	    push(@$outdated,'OUTDATED '.$dist.' wanted module: v'.
		 $vers_mod.'; '.$vstr.' (VERSION_FROM is '.
		 $fs.') want dist '.$module.' version '.$vers_dist.'.'. "\n");
	    push(@$to_update,$dist);
	} elsif ($fsflag) {
	    $vstr=~/found v(.*)/;
	    my $vc=$1;
	    if ($vc eq $vers_mod) {
		push(@$veryokay,'VERYOKAY '.$dist.' wanted: v'.
		     $vers_mod.'; '.$vstr.' (VERSION_FROM is '.$fs.
		     ') want dist '.$module.' version '.$vers_dist."\n");
	    } else {
		push(@$okay,'OKAY     '.$dist.' wanted: v'.
		     $vers_mod.'; '.$vstr.' (VERSION_FROM is '.$fs.').'."\n");
	    }
	}
    }
}

print("\n".'SYNOPSIS'."\n");

# ========================================================== The stable report.
print('**** STABLE REPORT (what a production server should worry about)'."\n");
if (@stable_missing)
  {
    print('There are '.scalar(@stable_missing).' CPAN distributions missing '.
	  'from this LON-CAPA system.'."\n");
  }
else
  {
    print('All perl modules needed by LON-CAPA appear to be present.'."\n");
  }
if (@stable_outdated)
  {
    print(scalar(@stable_outdated).' CPAN distributions are out-dated '.
	  'on this LON-CAPA system.'."\n");
  }
if (@stable_veryokay)
  {
    print(scalar(@stable_veryokay).' CPAN distributions are an exact match '.
	  '(based on version number).'."\n");
#    print @stable_veryokay;
  }
if (@stable_okay)
  {
    print(scalar(@stable_okay).' CPAN dists have a version number '.
	  'higher than expected'.
	  ' (probably okay).'. "\n");
  }
print("\n");

# ===================================================== The development report.
print('**** DEVELOPMENT REPORT (do not worry about this unless you are a'.
      ' coder)'."\n");
if (@dev_missing)
  {
    print('There are '.scalar(@dev_missing).' CPAN distributions missing '.
	  'from this LON-CAPA system.'."\n");
  }
else
  {
    print('All perl modules needed by LON-CAPA appear to be present.'."\n");
  }
if (@dev_outdated)
  {
    print(scalar(@dev_outdated).' CPAN distributions are out-dated '.
	  'on this LON-CAPA system.'."\n");
  }
if (@dev_veryokay)
  {
    print(scalar(@dev_veryokay).' CPAN distributions are an exact match '.
	  '(based on version number).'."\n");
#    print @dev_veryokay;
  }
if (@dev_okay)
  {
    print(scalar(@stable_okay).' CPAN dists have a version number '.
	  'higher than expected'.
	  ' (probably okay).'. "\n");
  }

my $detailstream;
if ($mode eq 'synopsis')
  {
    print("\n".'**** NOTE ****'."\n".
	  'After everything completes, please view the CPAN_STATUS_REPORT'.
	  ' file for more '."\n".'information on resolving your perl modules.'.
	  "\n");

    print('* HIT RETURN WHEN READY TO CONTINUE *'."\n");
    my $returnkey=<>;
    open(OUT,'>CPAN_STATUS_REPORT');
    $detailstream=\*OUT;
  }
else
  {
    $detailstream=\*STDOUT;
  }
print($detailstream 
      "\n".'DETAILED STATUS REPORT'."\n"); # Header of status report.

# Print advisory notices.
print($detailstream
      "\n".'(Consult loncapa/doc/otherfiles/perl_modules.txt for '.
      'information on'."\n".
      ' manual build instructions.)'."\n");
print($detailstream
      "\n".'(**** IMPORTANT NOTICE **** HTML-Parser needs to be patched '.
      "\n".' as described in loncapa/doc/otherfiles/perl_modules.txt)'.
      "\n");

print($detailstream
      "\n".'For manual installation of CPAN distributions, visit'."\n".
      'http://search.cpan.org/dist/DistName'."\n".
      'where DistName is something like "HTML-Parser" or "libwww-perl".'.
      "\n");

print($detailstream
      "\n".'For automatic installation of CPAN distributions, visit'."\n".
      'http://install.lon-capa.org/resources/cpanauto/DistName.bin'."\n".
      'where DistName.bin is something like "HTML-Parser.bin" or '.
      '"libwww-perl.bin".'."\n");

# Print detailed report of stable.
print($detailstream
      "\n".'STABLE (DETAILED REPORT)'."\n");
print $detailstream @stable_missing;
print $detailstream @stable_outdated;
print $detailstream @stable_veryokay;
print $detailstream @stable_okay;
print($detailstream "\n".'DEVELOPMENT (DETAILED REPORT)'."\n");
print $detailstream @dev_missing;
print $detailstream @dev_outdated;
print $detailstream @dev_veryokay;
print $detailstream @dev_okay;

if ($mode eq "html")
  {
    print(<<END);
</pre>
</body>
</html>
END
  }

if ($mode =~ /^update(dev|stable)$/) {
    use CPAN;
    my $type=$1;
    print $detailstream 'Attempting to do a '.$type.' update'."\n";
    my $to_update;
    if ($type eq 'dev') {
	$to_update=\@dev_to_update;
    } elsif ($type eq 'stable') {
	$to_update=\@stable_to_update;
    }
    foreach my $dist (@$to_update) {
	my $module=$dist_module_hash{$dist};
	my ($vers_mod,$vers_dist);
	if ($type eq 'dev') {
	    $vers_mod=$module_dev_version_hash{$module};
	    $vers_dist=$dist_dev_version_hash{$dist};
	} elsif ($type eq 'stable') {
	    $vers_mod=$module_stable_version_hash{$module};
	    $vers_dist=$dist_stable_version_hash{$dist};
	}
	install($module);
    }
}
# ================================================================ Subroutines.
# Note that "vers_cmp" and "have_vers" are adapted from a bugzilla version 2.16
# "checksetup.pl" script.

# ------------ vers_cmp : compare two version numbers and see which is greater.
# vers_cmp is adapted from Sort::Versions 1.3 1996/07/11 13:37:00 kjahds,
# which is not included with Perl by default, hence the need to copy it here.
# Seems silly to require it when this is the only place we need it...
sub vers_cmp
  {
    if (@_ < 2) { die "not enough parameters for vers_cmp" }
    if (@_ > 2) { die "too many parameters for vers_cmp" }
    my ($a, $b) = @_;
    my (@A) = ($a =~ /(\.|\d+|[^\.\d]+)/g);
    my (@B) = ($b =~ /(\.|\d+|[^\.\d]+)/g);
    my ($A,$B);
    while (@A and @B)
      {
        $A = shift @A;
        $B = shift @B;
        if ($A eq "." and $B eq ".")
          {
            next;
          }
        elsif ( $A eq "." )
          {
            return -1;
          }
        elsif ( $B eq "." )
          {
            return 1;
          }
        elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/)
          {
            return $A <=> $B if $A <=> $B;
          }
        else
          {
            $A = uc $A;
            $B = uc $B;
            return $A cmp $B if $A cmp $B;
          }
      }
    @A <=> @B;
  }

# --------------- have_vers: syntax check the version number and call vers_cmp.
# This was originally clipped from the libnet Makefile.PL, adapted here to
# use the above vers_cmp routine for accurate version checking.
sub have_vers
  {
    my ($pkg, $wanted) = @_;
    my ($msg, $vnum, $vstr);
    no strict 'refs';
    # printf("Checking for %15s %-9s ", $pkg, !$wanted?'(any)':"(v$wanted)");

    eval { my $p; ($p = $pkg . ".pm") =~ s!::!/!g; require $p; };

    $vnum = ${"${pkg}::VERSION"} || ${"${pkg}::Version"} || 0;
    $vnum = -1 if $@;

    if ($vnum eq "-1") # string compare just in case it's non-numeric
      {
        $vstr = "not found";
      }
    elsif (vers_cmp($vnum,"0") > -1)
      {
        $vstr = "found v$vnum";
      }
    else
      {
        $vstr = "found unknown version";
      }

    my $vok = (vers_cmp($vnum,$wanted) > -1);
    # print ((($vok) ? "ok: " : " "), "$vstr\n");
    return ($vok,$vstr);
  }
