[LON-CAPA-cvs] cvs: modules /raeburn checksubcalls.pl
raeburn
raeburn@source.lon-capa.org
Sun, 31 Jan 2010 19:19:09 -0000
This is a MIME encoded message
--raeburn1264965549
Content-Type: text/plain
raeburn Sun Jan 31 19:19:09 2010 EDT
Added files:
/modules/raeburn checksubcalls.pl
Log:
- Check for existence of subroutines called in LON-CAPA scripts/modules
within a LON-CAPA installation.
--raeburn1264965549
Content-Type: text/plain
Content-Disposition: attachment; filename="raeburn-20100131191909.txt"
Index: modules/raeburn/checksubcalls.pl
+++ modules/raeburn/checksubcalls.pl
#! /usr/bin/perl
# $Id: checksubcalls.pl,v 1.1 2010/01/31 19:19:08 raeburn Exp $
#########################################################
# checksubcalls.pl
#
# Stuart Raeburn, January 10, 2010
#
#########################################################
#
# Script to check for existence of subroutines called within LON-CAPA
# perl scripts and modules in /home/httpd/lib/perl/Apache, /home/httpd/perl,
# and /home/httpd/lib/perl/LONCAPA
#
use strict;
my $dir;
my $apachepath = "/home/httpd/lib/perl/Apache";
my $loncapapath = "/home/httpd/lib/perl/LONCAPA";
my $perlpath = "/home/httpd/perl";
my (%apachesubs,%apachedeps,%loncapasubs,%loncapadeps,%usedpkg);
&verify_subs('pm',$apachepath,\%apachesubs,\%apachedeps,\%loncapadeps,\%usedpkg);
&verify_subs('pm',$loncapapath,\%loncapasubs,\%apachedeps,\%loncapadeps,\%usedpkg);
&verify_subs('pl',$perlpath,\%loncapasubs,\%apachedeps,\%loncapadeps,\%usedpkg);
foreach my $item (sort(keys(%apachedeps))) {
if (ref($apachedeps{$item}) eq 'HASH') {
foreach my $module (sort(keys(%{$apachedeps{$item}}))) {
if (ref($apachedeps{$item}{$module}) eq 'HASH') {
foreach my $sub (sort(keys(%{$apachedeps{$item}{$module}}))) {
unless ($apachesubs{$module}{$sub}) {
print 'Apache::'.$item.' needs '.$module.'::'."$sub\n";
}
}
}
}
}
}
foreach my $item (sort(keys(%loncapadeps))) {
if (ref($loncapadeps{$item}) eq 'HASH') {
foreach my $module (sort(keys(%{$loncapadeps{$item}}))) {
if (ref($loncapadeps{$item}{$module}) eq 'HASH') {
foreach my $sub (sort(keys(%{$loncapadeps{$item}{$module}}))) {
unless ($loncapasubs{$module}{$sub}) {
print 'LONCAPA::'.$item.' needs '.$module.'::'."$sub\n";
}
}
}
}
}
}
sub verify_subs {
my ($ext,$dirpath,$subshashref,$apachedeps,$loncapadeps,$usedpkgref)=@_;
my $dir;
return unless((ref($subshashref) eq 'HASH') && (ref($apachedeps) eq 'HASH') && (ref($loncapadeps) eq 'HASH') && (ref($usedpkgref) eq 'HASH'));
if (opendir($dir,$dirpath)) {
my @modules;
if ($ext eq 'pm') {
@modules = grep(/\.\Q$ext\E$/,readdir($dir));
} elsif ($ext eq 'pl') {
@modules = grep(/\.\Q$ext\E$/,readdir($dir));
}
if ($dirpath eq '/home/httpd/perl') {
push(@modules,('lond','lonsql','loncnew','loncron','lonr','lonmemcached','lonhttpd'));
}
foreach my $item (@modules) {
if (-f "$dirpath/$item") {
if (open(my $fh, "<$dirpath/$item")) {
my $package;
if ($ext eq 'pm') {
($package) = ($item =~ /^(.+)\.\Q$ext\E$/);
} else {
$package = $item;
}
my %localsub;
my $inpod = '';
my $inprint = '';
while (<$fh>) {
next if (/^\s*#/);
if (/^\s*use\s+([\w\-\:]+)(;|\s)/) {
unless ($1 eq 'strict') {
$usedpkgref->{$package}{$1} = 1;
}
}
if (/^=pod/) {
$inpod = 1;
}
if (/(=|print\s)\s*(qq|qw)([\|\{\/\(])/) {
$inprint = $3;
}
unless ($inpod || $inprint) {
if (/^\s*sub\s+([\w\-]+)\s*\(?[\$\@]*\)?\s*[\r\n\f]*\{\s*/s) {
$subshashref->{$package}{$1} = 1;
} elsif (/[^\$]Apache\:\:([\w\-]+)\:\:([\w\-]+)\([^\)]*\)/) {
$apachedeps->{$package}{$1}{$2} = 1;
} elsif (/[^\$]LONCAPA\:\:([\w\-]+)\:\:([\w\-]+)\([^\)]*\)/) {
$loncapadeps->{$package}{$1}{$2} = 1;
} elsif (/\&([\w\-]+)\([^\)]*\)/) {
my $locsub = $1;
unless (($locsub eq '___') ||
($locsub eq 'mt') ||
($locsub eq 'mt_user') ||
($locsub eq 'mtn')) {
if ($package eq 'lonmenu') {
unless ($locsub = ~ /^(go|gccstr|annotate)$/) {
$localsub{$1} = 1;
}
} else {
$localsub{$1} = 1;
}
}
}
}
if (/^=cut/) {
$inpod = '';
}
if ($inprint ne '') {
my $closure = $inprint;
if ($inprint eq '{') {
$closure = '}';
} elsif ($inprint eq '(') {
$closure = ')';
}
if (/(^|[^\\])\Q$closure\E\s*[.;]/) {
$inprint = '';
}
}
}
close($fh);
foreach my $key (sort(keys(%localsub))) {
unless($subshashref->{$package}{$key}) {
if ($key eq 'escape' || $key eq 'unescape' || $key eq 'propath' || $key eq 'add_get_param' || $key eq 'tie_domain_hash' || $key eq 'untie_domain_hash' || $key eq 'tie_user_hash' || $key eq 'untie_user_hash') {
unless ($usedpkgref->{$package}{'LONCAPA'}) {
print "$package -- LONCAPA::$key is needed but no 'use LONCAPA'\n";
}
} elsif ($key =~ /^GDBM_(READER|WRITER|WRCREAT|NEWDB)$/) {
unless ($usedpkgref->{$package}{'GDBM_File'}) {
print "$package -- GDBM_File::$key is needed but no 'use GDBM_File'\n";
}
} elsif ($key eq 'thaw' || $key eq 'freeze' || $key eq 'nfreeze') {
unless ($usedpkgref->{$package}{'Storable'}) {
print "$package -- Storable::$key is needed but no 'use Storable'\n";
}
} elsif ($key eq 'gettimeofday' || $key eq 'tv_interval') {
unless ($usedpkgref->{$package}{'Time::HiRes'}) {
print "$package -- Time::HiRes::$key is needed but no 'use Time::HiRes'\n";
}
} elsif ($key eq 'Dumper') {
unless($usedpkgref->{$package}{'Data::Dumper'}) {
print "$package -- Data::Dumper::$key is needed but no 'use Data::Dumper'\n";
}
} elsif ($key eq 'uri_escape') {
unless ($usedpkgref->{$package}{'URI::Escape'}) {
print "$package -- URI::Escape::$key is needed but no 'use GDBM_File'\n";
}
} elsif ($key eq 'compare') {
unless ($usedpkgref->{$package}{'File::Compare'}) {
print "$package -- File::Compare::$key is needed but no 'use File::Compare'\n";
}
} elsif ($key eq 'UnixDate') {
unless ($usedpkgref->{$package}{'Date::Manip'}) {
print "$package -- Date::Manip::$key is needed but no 'use Date::Manip'\n";
}
} elsif ($key eq 'getcwd') {
unless ($usedpkgref->{$package}{'Cwd'}) {
print "$package -- Cwd::$key is needed but no 'use Cwd'\n";
}
} elsif ($key eq 'fileparse') {
unless ($usedpkgref->{$package}{'File::Basename'}) {
print "$package -- File::Basename::$key is needed but no 'use File::Basename'\n";
}
} elsif ($key eq 'hostname') {
unless ($usedpkgref->{$package}{'Sys::Hostname'}) {
print "$package -- Sys::Hostname::$key is needed but no 'use Sys::Hostname'\n";
}
} elsif ($key eq 'md5_hex') {
unless ($usedpkgref->{$package}{'Digest::MD5'}) {
print "$package -- Digest::MD5::$key is needed but no 'use Digest::MD5'\n";
}
} elsif ($key eq 'WNOHANG') {
unless ($usedpkgref->{$package}{'POSIX'}) {
print "$package -- POSIX::$key is needed but no 'use POSIX'\n";
}
} elsif ($key eq 'encode_entities') {
unless ($usedpkgref->{$package}{'HTML::Entities'}) {
print "$package -- HTML::Entities::$key is needed but no 'use HTML::Entities'\n";
}
} else {
print "$package -- $key is called as an internal subroutine, but package doesn't have one - is it imported?\n";
}
}
}
}
}
}
}
return;
}
--raeburn1264965549--