Return to perltest.pl CVS log

Up to [LON-CAPA] / loncom / build / system_dependencies

- now you can send it the command 'updatedev' or 'updatestable' which will attempt to do CPAN updates on modules that are either outdated or missing, Which works alot of the time
- remove the _ref from some vars

#!/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);
  }