home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / TestReport.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-12  |  2.1 KB  |  89 lines
  1. package ModPerl::TestReport;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. use base qw(Apache::TestReportPerl);
  7.  
  8. my @interesting_packages = qw(
  9.     CGI
  10.     Apache::Request
  11.     mod_perl
  12.     LWP
  13. );
  14.  
  15. # we want to see only already installed packages, so skip over
  16. # modules that are about to be installed
  17. my @skip_dirs = qw(
  18.     blib/lib
  19.     blib/lib/Apache2
  20.     blib/arch
  21.     blib/arch/Apache2
  22.     lib
  23. );
  24. my $skip_dir_str = join '|', map { s|/|[/\\\\]|g; $_ } @skip_dirs;
  25. my $skip_dir_pat = qr|[/\\]($skip_dir_str)[/\\]*$|;
  26.  
  27. sub packages {
  28.  
  29.     # search in Apache2/ subdirs too
  30.     eval { require Apache2 };
  31.     my @inc = grep !/$skip_dir_pat/, @INC;
  32.  
  33.     my %packages = ();
  34.     my $max_len = 0;
  35.     for my $package (sort @interesting_packages ) {
  36.         $max_len = length $package if length $package > $max_len;
  37.         my $filename = package2filename($package);
  38.         my @ver = ();
  39.         for my $dir (@inc) {
  40.             my $path = "$dir/$filename";
  41.             if (-e $path) {
  42.                 no warnings 'redefine';
  43.                 my $ver = eval { require $path;
  44.                                  delete $INC{$path};
  45.                                  $package->VERSION;
  46.                          };
  47.                 # two versions could be installed (one under Apache2/)
  48.                 push @{ $packages{$package} }, $ver if $ver;
  49.             }
  50.         }
  51.     }
  52.  
  53.     my @lines = "*** Packages of interest status:\n";
  54.  
  55.     for my $package (sort @interesting_packages) {
  56.         my $vers = exists $packages{$package} 
  57.             ? join ", ", sort @{ $packages{$package} }
  58.             : "-";
  59.         push @lines, sprintf "%-${max_len}s: %s", $package, $vers;
  60.     }
  61.  
  62.     return join "\n", @lines, '';
  63. }
  64.  
  65. sub config {
  66.     my $self = shift;
  67.  
  68.     my @report = ();
  69.  
  70.     # core config
  71.     push @report, ModPerl::Config::as_string();
  72.  
  73.     # installed packages
  74.     push @report, $self->packages;
  75.  
  76.     # this report is generated by user/group
  77.  
  78.     return join "\n", @report;
  79. }
  80.  
  81. sub package2filename {
  82.     my $package = shift;
  83.     $package =~ s|::|/|g;
  84.     $package .= ".pm";
  85.     return $package;
  86. }
  87.  
  88. 1;
  89.