Initial Commit
This commit is contained in:
Riley Schneider
100
database/perl/lib/HTML/Perlinfo/Apache.pm
Normal file
100
database/perl/lib/HTML/Perlinfo/Apache.pm
Normal file
@@ -0,0 +1,100 @@
|
||||
package HTML::Perlinfo::Apache;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use HTML::Perlinfo::Common;
|
||||
|
||||
|
||||
|
||||
sub new {
|
||||
my %apache;
|
||||
my $env = ( $ENV{SERVER_SOFTWARE} || "" ) =~ /apache/i;
|
||||
my $mp = exists $ENV{MOD_PERL};
|
||||
$apache{'env'} = $env;
|
||||
$apache{'mp'} = $mp;
|
||||
bless \%apache;
|
||||
}
|
||||
|
||||
sub has {
|
||||
my ( $self, @opts ) = @_;
|
||||
for my $opt (@opts) {
|
||||
return 0 unless $self->{$opt};
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub print_apache {
|
||||
|
||||
my $self = shift;
|
||||
my @mods;
|
||||
my ($version, $hostname, $port, $mp_status) = ("<i>Not detected</i>") x 7;
|
||||
|
||||
$mp_status = 'enabled' if $self->has qw(mp);
|
||||
|
||||
($version) = $ENV{'SERVER_SOFTWARE'} =~ /(\d+[\.\d]*)/
|
||||
if (defined $ENV{'SERVER_SOFTWARE'} && $ENV{'SERVER_SOFTWARE'} =~ /\d+[\.\d]*/);
|
||||
|
||||
|
||||
return join '', print_table_row(2, "Apache Version", "$version"),
|
||||
(defined($ENV{'SERVER_NAME'}) && defined($ENV{'SERVER_PORT'})) ?
|
||||
print_table_row(2, "Hostname:Port", "$ENV{'SERVER_NAME'} : $ENV{'SERVER_PORT'}"):
|
||||
print_table_row(2, "Hostname:Port", "$hostname : $port"),
|
||||
print_table_row(2, "mod_perl", "$mp_status");
|
||||
}
|
||||
|
||||
sub print_modperl {
|
||||
|
||||
my ($version_status, $version_number) = ("<i>Not detected</i>") x 3;
|
||||
|
||||
$version_status = '1.0';
|
||||
$version_status = '2.0 or higher' if $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2;
|
||||
($version_number) = $ENV{MOD_PERL} =~ /^\S+\/(\d+(?:[\.\_]\d+)+)/;
|
||||
$version_number =~ s/_//g;
|
||||
$version_number =~ s/(\.[^.]+)\./$1/g;
|
||||
unless ($version_status eq '2.0 or higher') {
|
||||
if ( $version_number >= 1.9901 ) {
|
||||
$version_status = '1.9 which is incompatible with 2.0';
|
||||
}
|
||||
}
|
||||
|
||||
return join '', print_box_start(0),
|
||||
"Running under mod_perl version $version_status (version number: $version_number)",
|
||||
print_box_end();
|
||||
|
||||
}
|
||||
|
||||
sub print_apache_environment {
|
||||
|
||||
|
||||
return join '', print_table_row(2, "DOCUMENT_ROOT", $ENV{'DOCUMENT_ROOT'}),
|
||||
print_table_row(2, "HTTP_ACCEPT", $ENV{'HTTP_ACCEPT'}),
|
||||
print_table_row(2, "HTTP_ACCEPT_CHARSET", $ENV{'HTTP_ACCEPT_CHARSET'}),
|
||||
print_table_row(2, "HTTP_ACCEPT_ENCODING", $ENV{'HTTP_ACCEPT_ENCODING'}),
|
||||
print_table_row(2, "HTTP_ACCEPT_LANGUAGE", $ENV{'HTTP_ACCEPT_LANGUAGE'}),
|
||||
print_table_row(2, "HTTP_CONNECTION", $ENV{'HTTP_CONNECTION'}),
|
||||
print_table_row(2, "HTTP_HOSTS", $ENV{'HTTP_HOSTS'}),
|
||||
print_table_row(2, "HTTP_KEEP_ALIVE", $ENV{'HTTP_KEEP_ALIVE'}),
|
||||
print_table_row(2, "HTTP_USER_AGENT", $ENV{'HTTP_USER_AGENT'}),
|
||||
print_table_row(2, "PATH", $ENV{'PATH'}),
|
||||
print_table_row(2, "REMOTE_ADDR", $ENV{'REMOTE_ADDR'}),
|
||||
print_table_row(2, "REMOTE_HOST", $ENV{'REMOTE_HOST'}),
|
||||
print_table_row(2, "REMOTE_PORT", $ENV{'REMOTE_PORT'}),
|
||||
print_table_row(2, "SCRIPT_FILENAME", $ENV{'SCRIPT_FILENAME'}),
|
||||
print_table_row(2, "SCRIPT_URI", $ENV{'SCRIPT_URI'}),
|
||||
print_table_row(2, "SCRIPT_URL", $ENV{'SCRIPT_URL'}),
|
||||
print_table_row(2, "SERVER_ADDR", $ENV{'SERVER_ADDR'}),
|
||||
print_table_row(2, "SERVER_ADMIN", $ENV{'SERVER_ADMIN'}),
|
||||
print_table_row(2, "SERVER_NAME", $ENV{'SERVER_NAME'}),
|
||||
print_table_row(2, "SERVER_PORT", $ENV{'SERVER_PORT'}),
|
||||
print_table_row(2, "SERVER_SIGNATURE", $ENV{'SERVER_SIGNATURE'}),
|
||||
print_table_row(2, "SERVER_SOFTWARE", $ENV{'SERVER_SOFTWARE'}),
|
||||
print_table_row(2, "GATEWAY_INTERFACE", $ENV{'GATEWAY_INTERFACE'}),
|
||||
print_table_row(2, "SERVER_PROTOCOL", $ENV{'SERVER_PROTOCOL'}),
|
||||
print_table_row(2, "REQUEST_METHOD", $ENV{'REQUEST_METHOD'}),
|
||||
print_table_row(2, "QUERY_STRING", $ENV{'QUERY_STRING'}),
|
||||
print_table_row(2, "REQUEST_URI", $ENV{'REQUEST_URI'}),
|
||||
print_table_row(2, "SCRIPT_NAME", $ENV{'SCRIPT_NAME'});
|
||||
|
||||
}
|
||||
1;
|
||||
|
||||
249
database/perl/lib/HTML/Perlinfo/Base.pm
Normal file
249
database/perl/lib/HTML/Perlinfo/Base.pm
Normal file
@@ -0,0 +1,249 @@
|
||||
package HTML::Perlinfo::Base;
|
||||
|
||||
|
||||
use HTML::Perlinfo::Common;
|
||||
use HTML::Perlinfo::General;
|
||||
use Carp ();
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my ($class, %params) = @_;
|
||||
my $self = {};
|
||||
$self->{full_page} = 1;
|
||||
$self->{title} = 0;
|
||||
$self->{bg_image} = '';
|
||||
$self->{bg_position} = 'center';
|
||||
$self->{bg_repeat} = 'no_repeat';
|
||||
$self->{bg_attribute} = 'fixed';
|
||||
$self->{bg_color} = '#ffffff';
|
||||
$self->{ft_family} = 'sans-serif';
|
||||
$self->{ft_color} = '#000000';
|
||||
$self->{lk_color} = '#000099';
|
||||
$self->{lk_decoration} = 'none';
|
||||
$self->{lk_bgcolor} = '';
|
||||
$self->{lk_hvdecoration} = 'underline';
|
||||
$self->{header_bgcolor} = '#9999cc';
|
||||
$self->{header_ftcolor} = '#000000';
|
||||
$self->{leftcol_bgcolor} = '#ccccff';
|
||||
$self->{leftcol_ftcolor} = '#000000';
|
||||
$self->{rightcol_bgcolor} = '#cccccc';
|
||||
$self->{rightcol_ftcolor} = '#000000';
|
||||
|
||||
foreach my $key (keys %params) {
|
||||
if (exists $self->{$key}) {
|
||||
$self->{$key} = $params{$key};
|
||||
}
|
||||
else {
|
||||
error_msg("$key is an invalid attribute");
|
||||
}
|
||||
}
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
|
||||
}
|
||||
|
||||
sub info_all {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_ALL)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_general();
|
||||
$html .= print_variables();
|
||||
$html .= print_thesemodules('core');
|
||||
$html .= print_license();
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
sub info_general {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_GENERAL)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_general('top');
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
|
||||
sub info_loaded {
|
||||
|
||||
my $self = shift;
|
||||
$self->{'title'} = 'perlinfo(INFO_LOADED)' unless $self->{'title'};
|
||||
my $html;
|
||||
$html .= $self->print_htmlhead() if $self->{'full_page'};
|
||||
|
||||
eval qq{
|
||||
|
||||
END {
|
||||
delete \$INC{'HTML/Perlinfo.pm'};
|
||||
\$html .= print_thesemodules('loaded',[values %INC]);
|
||||
\$html .= print_variables();
|
||||
\$html .= '</div></body></html>' if \$self->{'full_page'};
|
||||
print \$html;
|
||||
}
|
||||
|
||||
}; die $@ if $@;
|
||||
|
||||
}
|
||||
|
||||
sub info_modules {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_MODULES)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{'full_page'};
|
||||
$html .= print_thesemodules('all');
|
||||
$html .= "</div></body></html>" if $self->{'full_page'};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
sub info_config {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_CONFIG)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_config('info_config');
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
sub info_apache {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_APACHE)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_httpd();
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
sub info_variables {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_VARIABLES)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_variables();
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
|
||||
sub info_license {
|
||||
my $self = shift;
|
||||
my %param = @_;
|
||||
error_msg("invalid parameter") if (defined $_[0] && exists $param{'links'} && ref $param{'links'} ne 'ARRAY');
|
||||
$self->links(@{$param{'links'}}) if exists $param{'links'};
|
||||
my $html;
|
||||
$self->{title} = 'perlinfo(INFO_LICENSE)' unless $self->{title};
|
||||
$html .= $self->print_htmlhead() if $self->{full_page};
|
||||
$html .= print_license();
|
||||
$html .= "</div></body></html>" if $self->{full_page};
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
|
||||
|
||||
sub print_htmlhead {
|
||||
|
||||
my $self = shift;
|
||||
|
||||
my $title = $self->{title};
|
||||
my $bg_image = $self->{bg_image};
|
||||
my $bg_position = $self->{bg_position};
|
||||
my $bg_repeat = $self->{bg_repeat};
|
||||
my $bg_attribute = $self->{bg_attribute};
|
||||
my $bg_color = $self->{bg_color};
|
||||
|
||||
my $ft_family = $self->{ft_family};
|
||||
my $ft_color = $self->{ft_color};
|
||||
my $lk_color = $self->{lk_color};
|
||||
my $lk_decoration = $self->{lk_decoration};
|
||||
my $lk_bgcolor = $self->{lk_bgcolor};
|
||||
my $lk_hvdecoration = $self->{lk_hvdecoration};
|
||||
|
||||
my $header_bgcolor = $self->{header_bgcolor};
|
||||
my $header_ftcolor = $self->{header_ftcolor};
|
||||
my $leftcol_bgcolor =$self->{leftcol_bgcolor};
|
||||
my $leftcol_ftcolor = $self->{leftcol_ftcolor};
|
||||
my $rightcol_bgcolor = $self->{rightcol_bgcolor};
|
||||
my $rightcol_ftcolor = $self->{rightcol_ftcolor};
|
||||
|
||||
my $html = <<"END_OF_HTML";
|
||||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
|
||||
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
||||
<head>
|
||||
<style type="text/css"><!--
|
||||
body {
|
||||
background-color: $bg_color;
|
||||
background-image: url($bg_image);
|
||||
background-position: $bg_position;
|
||||
background-repeat: $bg_repeat;
|
||||
background-attachment: $bg_attribute;
|
||||
color: $ft_color;}
|
||||
body, td, th, h1, h2 {font-family: $ft_family;}
|
||||
pre {margin: 0px; font-family: monospace;}
|
||||
a:link {color: $lk_color; text-decoration: $lk_decoration; background-color: $lk_bgcolor;}
|
||||
a:hover {text-decoration: $lk_hvdecoration;}
|
||||
table {border-collapse: collapse;}
|
||||
.center {text-align: center;}
|
||||
.center table { margin-left: auto; margin-right: auto; text-align: left;}
|
||||
.center th { text-align: center !important; }
|
||||
td, th { border: 1px solid #000000; font-size: 75%; vertical-align: baseline;}
|
||||
.modules table {border: 0;}
|
||||
.modules td { border:0; font-size: 100%; vertical-align: baseline;}
|
||||
.modules th { border:0; font-size: 100%; vertical-align: baseline;}
|
||||
h1 {font-size: 150%;}
|
||||
h2 {font-size: 125%;}
|
||||
.p {text-align: left;}
|
||||
.e {background-color: $leftcol_bgcolor; font-weight: bold; color: $leftcol_ftcolor;}
|
||||
.h {background-color: $header_bgcolor; font-weight: bold; color: $header_ftcolor;}
|
||||
.v {background-color: $rightcol_bgcolor; color: $rightcol_ftcolor;}
|
||||
i {color: #666666; background-color: #cccccc;}
|
||||
img {float: right; border: 0px;}
|
||||
hr {width: 600px; background-color: #cccccc; border: 0px; height: 1px; color: #000000;}
|
||||
//--></style>
|
||||
<title>$title</title>
|
||||
</head>
|
||||
<body><div class="center">
|
||||
END_OF_HTML
|
||||
|
||||
defined wantarray ? return $html : print $html;
|
||||
}
|
||||
|
||||
sub links {
|
||||
|
||||
my $self = shift;
|
||||
my $args = process_args(@_, \&check_args);
|
||||
if (exists $args->{'0'}) {
|
||||
$HTML::Perlinfo::Common::links{'all'} = 0;
|
||||
}
|
||||
elsif (exists $args->{'1'}) {
|
||||
$HTML::Perlinfo::Common::links{'all'} = 1;
|
||||
}
|
||||
elsif (exists $args->{'docs'} && not exists $args->{'local'}) {
|
||||
$HTML::Perlinfo::Common::links{'docs'} = $args->{'docs'};
|
||||
}
|
||||
elsif (exists $args->{'local'} && not exists $args->{'docs'}) {
|
||||
$HTML::Perlinfo::Common::links{'local'} = $args->{'local'};
|
||||
}
|
||||
elsif (exists $args->{'docs'} && exists $args->{'local'}) {
|
||||
$HTML::Perlinfo::Common::links{'docs'} = $args->{'docs'},
|
||||
$HTML::Perlinfo::Common::links{'local'} = $args->{'local'},
|
||||
}
|
||||
}
|
||||
1;
|
||||
515
database/perl/lib/HTML/Perlinfo/Common.pm
Normal file
515
database/perl/lib/HTML/Perlinfo/Common.pm
Normal file
@@ -0,0 +1,515 @@
|
||||
package HTML::Perlinfo::Common;
|
||||
use CGI qw(escapeHTML);
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(initialize_globals print_table_colspan_header print_table_row print_table_color_start print_table_color_end print_color_box print_table_row_color print_table_start print_table_end print_box_start print_box_end print_hr print_table_header print_section print_license add_link check_path check_args check_module_args perl_version release_date process_args error_msg match_string);
|
||||
require Exporter;
|
||||
|
||||
use Carp ();
|
||||
|
||||
our %links;
|
||||
|
||||
%links = (
|
||||
'all' => 1,
|
||||
'local' => 0,
|
||||
'docs' => 1,
|
||||
);
|
||||
|
||||
|
||||
##### The following is lifted from File::Which 0.05 by Per Einar Ellefsen.
|
||||
##### The check_path sub uses the which sub.
|
||||
#############
|
||||
use File::Spec;
|
||||
|
||||
my $Is_VMS = ($^O eq 'VMS');
|
||||
my $Is_MacOS = ($^O eq 'MacOS');
|
||||
my $Is_DOSish = (($^O eq 'MSWin32') or
|
||||
($^O eq 'dos') or
|
||||
($^O eq 'os2'));
|
||||
|
||||
# For Win32 systems, stores the extensions used for
|
||||
# executable files
|
||||
# For others, the empty string is used
|
||||
# because 'perl' . '' eq 'perl' => easier
|
||||
my @path_ext = ('');
|
||||
if ($Is_DOSish) {
|
||||
if ($ENV{PATHEXT} and $Is_DOSish) { # WinNT. PATHEXT might be set on Cygwin, but not used.
|
||||
push @path_ext, split ';', $ENV{PATHEXT};
|
||||
}
|
||||
else {
|
||||
push @path_ext, qw(.com .exe .bat); # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
|
||||
}
|
||||
}
|
||||
elsif ($Is_VMS) {
|
||||
push @path_ext, qw(.exe .com);
|
||||
}
|
||||
|
||||
sub which {
|
||||
my ($exec) = @_;
|
||||
|
||||
return undef unless $exec;
|
||||
|
||||
my $all = wantarray;
|
||||
my @results = ();
|
||||
|
||||
# check for aliases first
|
||||
if ($Is_VMS) {
|
||||
my $symbol = `SHOW SYMBOL $exec`;
|
||||
chomp($symbol);
|
||||
if (!$?) {
|
||||
return $symbol unless $all;
|
||||
push @results, $symbol;
|
||||
}
|
||||
}
|
||||
if ($Is_MacOS) {
|
||||
my @aliases = split /\,/, $ENV{Aliases};
|
||||
foreach my $alias (@aliases) {
|
||||
# This has not been tested!!
|
||||
# PPT which says MPW-Perl cannot resolve `Alias $alias`,
|
||||
# let's just hope it's fixed
|
||||
if (lc($alias) eq lc($exec)) {
|
||||
chomp(my $file = `Alias $alias`);
|
||||
last unless $file; # if it failed, just go on the normal way
|
||||
return $file unless $all;
|
||||
push @results, $file;
|
||||
# we can stop this loop as if it finds more aliases matching,
|
||||
# it'll just be the same result anyway
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my @path = File::Spec->path();
|
||||
unshift @path, File::Spec->curdir if $Is_DOSish or $Is_VMS or $Is_MacOS;
|
||||
|
||||
for my $base (map { File::Spec->catfile($_, $exec) } @path) {
|
||||
for my $ext (@path_ext) {
|
||||
my $file = $base.$ext;
|
||||
|
||||
if ((-x $file or # executable, normal case
|
||||
($Is_MacOS || # MacOS doesn't mark as executable so we check -e
|
||||
($Is_DOSish and grep { $file =~ /$_$/i } @path_ext[1..$#path_ext])
|
||||
# DOSish systems don't pass -x on non-exe/bat/com files.
|
||||
# so we check -e. However, we don't want to pass -e on files
|
||||
# that aren't in PATHEXT, like README.
|
||||
and -e _)
|
||||
) and !-d _)
|
||||
{ # and finally, we don't want dirs to pass (as they are -x)
|
||||
|
||||
|
||||
return $file unless $all;
|
||||
push @results, $file; # Make list to return later
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if($all) {
|
||||
return @results;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
## End File::Which code
|
||||
|
||||
sub check_path {
|
||||
|
||||
return add_link('local', which("$_[0]")) if which("$_[0]");
|
||||
return "<i>not in path</i>";
|
||||
|
||||
}
|
||||
|
||||
sub match_string {
|
||||
my($module_name, $string) = @_;
|
||||
|
||||
my $result = 0;
|
||||
my @string = (ref $string eq 'ARRAY') ? @$string : ($string);
|
||||
foreach(@string) {
|
||||
$result = index(lc($module_name), lc($_));
|
||||
last if ($result != -1);
|
||||
}
|
||||
return ($result == -1) ? 0 : 1;
|
||||
|
||||
}
|
||||
|
||||
sub perl_version {
|
||||
my $version;
|
||||
if ($] >= 5.006) {
|
||||
$version = sprintf "%vd", $^V;
|
||||
}
|
||||
else { # else time to update Perl!
|
||||
$version = "$]";
|
||||
}
|
||||
return $version;
|
||||
}
|
||||
|
||||
sub release_date {
|
||||
|
||||
# when things escaped
|
||||
%released = (
|
||||
5.000 => '1994-10-17',
|
||||
5.001 => '1995-03-14',
|
||||
5.002 => '1996-02-96',
|
||||
5.00307 => '1996-10-10',
|
||||
5.004 => '1997-05-15',
|
||||
5.005 => '1998-07-22',
|
||||
5.00503 => '1999-03-28',
|
||||
5.00405 => '1999-04-29',
|
||||
5.006 => '2000-03-22',
|
||||
5.006001 => '2001-04-08',
|
||||
5.007003 => '2002-03-05',
|
||||
5.008 => '2002-07-19',
|
||||
5.008001 => '2003-09-25',
|
||||
5.009 => '2003-10-27',
|
||||
5.008002 => '2003-11-05',
|
||||
5.006002 => '2003-11-15',
|
||||
5.008003 => '2004-01-14',
|
||||
5.00504 => '2004-02-23',
|
||||
5.009001 => '2004-03-16',
|
||||
5.008004 => '2004-04-21',
|
||||
5.008005 => '2004-07-19',
|
||||
5.008006 => '2004-11-27',
|
||||
5.009002 => '2005-04-01',
|
||||
5.008007 => '2005-05-30',
|
||||
5.009003 => '2006-01-28',
|
||||
5.008008 => '2006-01-31',
|
||||
5.009004 => '2006-08-15',
|
||||
5.009005 => '2007-07-07',
|
||||
5.010000 => '2007-12-18',
|
||||
);
|
||||
|
||||
# Do we have Module::Corelist
|
||||
eval{require Module::CoreList};
|
||||
if ($@) { # no
|
||||
return ($released{$]}) ? $released{$]} : "unknown";
|
||||
}
|
||||
else { # yes
|
||||
return ($Module::CoreList::released{$]}) ? $Module::CoreList::released{$]} : "unknown";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub check_args {
|
||||
|
||||
my ($key, $value) = @_;
|
||||
my ($message, %allowed);
|
||||
@allowed{qw(docs local 0 1)} = ();
|
||||
|
||||
if (not exists $allowed{$key}) {
|
||||
$message = "$key is an invalid links parameter";
|
||||
}
|
||||
elsif ($key =~ /(?:docs|local)/ && $value !~ /^(?:0|1)$/i) {
|
||||
$message = "$value is an invalid value for the $key parameter in the links attribute";
|
||||
}
|
||||
|
||||
error_msg("$message") if $message;
|
||||
|
||||
}
|
||||
|
||||
sub check_module_args {
|
||||
|
||||
my ($key, $value) = @_;
|
||||
my ($message, %allowed);
|
||||
@allowed{qw(from columns sort_by color link show_only section full_page show_inc show_dir files_in)} = ();
|
||||
|
||||
if (not exists $allowed{$key}) {
|
||||
$message = "$key is an invalid print_modules parameter";
|
||||
}
|
||||
elsif ($key eq 'sort_by' && $value !~ /^(?:name|version)$/i) {
|
||||
$message = "$value is an invalid sort";
|
||||
}
|
||||
elsif ($key =~ /^(?:color|link|columns|files_in)$/ && ref($value) ne 'ARRAY') {
|
||||
$message = "The $key parameter value is not an array reference";
|
||||
}
|
||||
elsif ($key eq 'columns' && grep(!/^(?:name|version|desc|path|core)$/, @{$value})) {
|
||||
$message = "Invalid column name in the $key parameter";
|
||||
}
|
||||
elsif ($key eq 'color' && @{$value} <= 1) {
|
||||
$message = "You didn't specify a module to color";
|
||||
}
|
||||
elsif ($key eq 'link' && @{$value} <= 1 && $value->[0] != 0) {
|
||||
$message = "You didn't provide a URL for the $key parameter";
|
||||
}
|
||||
elsif ($key eq 'show_only' && (ref($value) ne 'ARRAY') && lc $value ne 'core') {
|
||||
$message = "$value is an invalid value for the $key parameter";
|
||||
}
|
||||
elsif ($key eq 'full_page' && $value != 0 && $value != 1 ) {
|
||||
$message = "$value is an invalid value for the $key parameter";
|
||||
}
|
||||
elsif ($key eq 'link' && ($value->[0] ne 'all' && $value->[0] != 0 && ref($value->[0]) ne 'ARRAY')) {
|
||||
$message = "Invalid first element in the $key parameter value";
|
||||
}
|
||||
error_msg("$message") if $message;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub process_args {
|
||||
# This sub returns a hash ref containing param args
|
||||
my %params;
|
||||
my $sub = pop @_ || die "No coderef provided\n"; # get the sub
|
||||
if (defined $_[0]) {
|
||||
while(my($key, $value) = splice @_, 0, 2) {
|
||||
$sub->($key, $value);
|
||||
if (exists $params{$key}){
|
||||
@key_value = ref(${$params{$key}}[0]) eq 'ARRAY' ? @{$params{$key}} : $params{$key};
|
||||
push @key_value,$value;
|
||||
$new_val = [@key_value];
|
||||
$params{$key} = $new_val;
|
||||
}
|
||||
else {
|
||||
$params{$key} = $value;
|
||||
}
|
||||
}
|
||||
}
|
||||
return \%params;
|
||||
}
|
||||
|
||||
sub error_msg {
|
||||
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
|
||||
Carp::croak "User error: $_[0]";
|
||||
}
|
||||
|
||||
# HTML subs
|
||||
|
||||
sub print_table_colspan_header {
|
||||
|
||||
return sprintf("<tr class=\"h\"><th colspan=\"%d\">%s</th></tr>\n", $_[0], $_[1]);
|
||||
|
||||
}
|
||||
|
||||
sub print_table_row {
|
||||
|
||||
|
||||
my $num_cols = $_[0];
|
||||
my $HTML = "<tr>";
|
||||
|
||||
for ($i=0; $i<$num_cols; $i++) {
|
||||
|
||||
$HTML .= sprintf("<td class=\"%s\">", ($i==0 ? "e" : "v" ));
|
||||
|
||||
my $row_element = $_[$i+1];
|
||||
if ((not defined ($row_element)) || ($row_element !~ /\S/)) {
|
||||
$HTML .= "<i>no value</i>";
|
||||
} else {
|
||||
my $elem_esc;
|
||||
if ($row_element eq "<i>no value</i>") {
|
||||
$elem_esc = $row_element;
|
||||
} else {
|
||||
$elem_esc = escapeHTML($row_element);
|
||||
}
|
||||
$HTML .= "$elem_esc";
|
||||
|
||||
}
|
||||
|
||||
$HTML .= " </td>";
|
||||
|
||||
}
|
||||
|
||||
$HTML .= "</tr>\n";
|
||||
return $HTML;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub print_table_color_start {
|
||||
|
||||
return qq~<table class="modules" cellpadding=4 cellspacing=4 border=0 width="600"><tr>\n~;
|
||||
}
|
||||
|
||||
sub print_table_color_end {
|
||||
|
||||
return '</tr></table>';
|
||||
}
|
||||
|
||||
|
||||
sub print_color_box {
|
||||
|
||||
return qq ~<td>
|
||||
<table border=0>
|
||||
<tr><td>
|
||||
<table class="modules" border=0 width=50 height=50 align=left bgcolor="$_[0]">
|
||||
<tr bgcolor="$_[0]">
|
||||
<td color="$_[0]">
|
||||
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</tr></td>
|
||||
<tr><td><small>$_[1]</small></td></tr>
|
||||
</table>
|
||||
</td>~;
|
||||
}
|
||||
|
||||
sub print_table_row_color {
|
||||
|
||||
my $num_cols = $_[0];
|
||||
my $HTML = $_[1] ? "<tr bgcolor=\"$_[1]\">" : "<tr>";
|
||||
|
||||
for ($i=0; $i<$num_cols; $i++) {
|
||||
|
||||
$HTML .= $_[1] ? "<td bgcolor=\"$_[1]\">" : sprintf("<td class=\"%s\">", ($i==0 ? "e" : "v" ));
|
||||
|
||||
my $row_element = $_[$i+2]; # start at the 2nd element
|
||||
if ((not defined ($row_element)) || ($row_element !~ /\S/)) {
|
||||
$HTML .= "<i>no value</i>";
|
||||
} else {
|
||||
my $elem_esc = $row_element;
|
||||
$HTML .= "$elem_esc";
|
||||
|
||||
}
|
||||
|
||||
$HTML .= " </td>";
|
||||
|
||||
}
|
||||
|
||||
$HTML .= "</tr>\n";
|
||||
return $HTML;
|
||||
}
|
||||
|
||||
sub print_table_start {
|
||||
|
||||
return "<table border=\"0\" cellpadding=\"3\" width=\"600\">\n";
|
||||
|
||||
}
|
||||
sub print_table_end {
|
||||
|
||||
return "</table><br />\n";
|
||||
|
||||
}
|
||||
sub print_box_start {
|
||||
|
||||
my $HTML = print_table_start();
|
||||
$HTML .= ($_[0] == 1) ? "<tr class=\"h\"><td>\n" : "<tr class=\"v\"><td>\n";
|
||||
return $HTML;
|
||||
}
|
||||
|
||||
|
||||
sub print_box_end {
|
||||
my $HTML = "</td></tr>\n";
|
||||
$HTML .= print_table_end();
|
||||
return $HTML;
|
||||
}
|
||||
|
||||
sub print_hr {
|
||||
return "<hr />\n";
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub print_table_header {
|
||||
|
||||
my($num_cols) = $_[0];
|
||||
my $HTML = "<tr class=\"h\">";
|
||||
|
||||
my $i;
|
||||
for ($i=0; $i<$num_cols; $i++) {
|
||||
my $row_element = $_[$i+1];
|
||||
$row_element = " " if (!$row_element);
|
||||
$HTML .= "<th>$row_element</th>";
|
||||
}
|
||||
|
||||
return "$HTML</tr>\n";
|
||||
}
|
||||
|
||||
|
||||
sub print_section {
|
||||
|
||||
return "<h2>" . $_[0] . "</h2>\n";
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub print_perl_license {
|
||||
|
||||
return <<"END_OF_HTML";
|
||||
<p>
|
||||
This program is free software; you can redistribute it and/or modify it under the terms of
|
||||
either the Artistic License or the GNU General Public License, which may be found in the Perl 5 source kit.
|
||||
</p>
|
||||
|
||||
<p>
|
||||
This program 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.
|
||||
</p>
|
||||
<p>
|
||||
Complete documentation for Perl, including FAQ lists, should be found on
|
||||
this system using `man perl' or `perldoc perl'. If you have access to the
|
||||
Internet, point your browser at @{[ add_link('same', 'http://www.perl.org/')]}, the Perl directory.
|
||||
</p>
|
||||
END_OF_HTML
|
||||
|
||||
}
|
||||
|
||||
sub print_license {
|
||||
|
||||
return join '', print_section("Perl License"),
|
||||
print_box_start(0),
|
||||
print_perl_license(),
|
||||
print_box_end();
|
||||
}
|
||||
|
||||
|
||||
sub add_link {
|
||||
|
||||
my ($type, $value, $link) = @_;
|
||||
return $value unless $links{'all'};
|
||||
|
||||
if ($type eq "cpan") {
|
||||
|
||||
return $value if $link && $link->[0] =~ /^[0]$/;
|
||||
|
||||
if ($link) {
|
||||
if (ref $link->[0] eq 'ARRAY' && ref $link->[1] ne 'ARRAY') {
|
||||
foreach (@{$link->[0]}) {
|
||||
if ($_ eq 'all' or match_string($value,$_)==1) {
|
||||
return '<a href=' . $link->[1] . $value .
|
||||
qq~ title="Click here to see $value documentation [Opens in a new window]"
|
||||
target="_blank">$value</a> ~
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (ref $link->[0] eq 'ARRAY' && ref $link->[1] eq 'ARRAY'){
|
||||
foreach my $lv (@$link) {
|
||||
if (ref $lv->[0] eq 'ARRAY') {
|
||||
foreach(@{$lv->[0]}) {
|
||||
if ($_ eq 'all' or match_string($value,$_)==1) {
|
||||
return '<a href=' . $lv->[1] . $value .
|
||||
qq~ title="Click here to see $value documentation [Opens in a new window]"
|
||||
target="_blank">$value</a> ~
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($lv->[0] eq 'all' or match_string($value,$lv->[0])==1) {
|
||||
return '<a href=' . $lv->[1] . $value .
|
||||
qq~ title="Click here to see $value documentation [Opens in a new window]"
|
||||
target="_blank">$value</a> ~
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($link->[0] eq 'all' or match_string($value,$link->[0])==1) {
|
||||
return '<a href=' . $link->[1] . $value .
|
||||
qq~ title="Click here to see $value documentation [Opens in a new window]"
|
||||
target="_blank">$value</a> ~
|
||||
}
|
||||
}
|
||||
return qq~ <a href="http://search.cpan.org/perldoc?$value"
|
||||
title="Click here to see $value on CPAN [Opens in a new window]" target="_blank">$value</a> ~;
|
||||
}
|
||||
elsif ($type eq "config") {
|
||||
return $value unless $links{'docs'};
|
||||
my ($letter) = $value =~ /^(.)/;
|
||||
return qq! <a href="http://search.cpan.org/~aburlison/Solaris-PerlGcc-1.3/config/5.006001/5.10/sparc/Config.pm#$letter">$value</a> !;
|
||||
}
|
||||
elsif ($type eq "local") {
|
||||
return $value unless $links{'local'};
|
||||
return qq~ <a href="file://$value" title="Click here to see $value [Opens in a new window]" target="_blank">$value</a> ~;
|
||||
}
|
||||
elsif ($type eq "same") {
|
||||
return qq~ <a href="$value">$value</a> ~;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
227
database/perl/lib/HTML/Perlinfo/General.pm
Normal file
227
database/perl/lib/HTML/Perlinfo/General.pm
Normal file
@@ -0,0 +1,227 @@
|
||||
package HTML::Perlinfo::General;
|
||||
|
||||
use base qw(Exporter);
|
||||
our @EXPORT = qw(print_httpd print_thesemodules print_config print_variables print_general);
|
||||
use CGI qw(url_param param);
|
||||
use POSIX qw(uname);
|
||||
use Config qw(%Config config_sh);
|
||||
use Net::Domain qw(hostname);
|
||||
use File::Spec;
|
||||
use HTML::Perlinfo::Common;
|
||||
use HTML::Perlinfo::Apache;
|
||||
|
||||
# Should search for Get, Post, Cookies, Session, and Environment.
|
||||
sub perl_print_gpcse_array {
|
||||
my $html;
|
||||
my($name) = @_;
|
||||
my ($gpcse_name, $gpcse_value);
|
||||
#POST names should be param() and get in url_param()
|
||||
if (defined($ENV{'QUERY_STRING'}) && length($ENV{'QUERY_STRING'}) >= 1) {
|
||||
foreach(url_param()) { $html .= print_table_row(2, "GET[\"$_\"]", url_param($_)); }
|
||||
}
|
||||
if (defined($ENV{'CONTENT_LENGTH'})) {
|
||||
foreach(param()) { $html .= print_table_row(2, "POST[\"$_\"]", param($_)); }
|
||||
}
|
||||
if (defined($ENV{'HTTP_COOKIE'})) {
|
||||
$cookies = $ENV{'HTTP_COOKIE'};
|
||||
@cookies = split(';',$cookies);
|
||||
foreach (@cookies) {
|
||||
($k,$v) = split('=',$_);
|
||||
$html .= print_table_row(2, "COOKIE[\"$k\"]", "$v");
|
||||
}
|
||||
}
|
||||
foreach my $key (sort(keys %ENV))
|
||||
{
|
||||
$gpcse_name = "$name" . '["' . "$key" . '"]';
|
||||
if ($ENV{$key}) {
|
||||
$gpcse_value = "$ENV{$key}";
|
||||
} else {
|
||||
$gpcse_value = "<i>no value</i>";
|
||||
}
|
||||
|
||||
|
||||
$html .= print_table_row(2, "$gpcse_name", "$gpcse_value");
|
||||
}
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub print_variables {
|
||||
|
||||
return join '', print_section("Environment"),
|
||||
print_table_start(),
|
||||
print_table_header(2, "Variable", "Value"),
|
||||
((defined($ENV{'SERVER_SOFTWARE'})) ? perl_print_gpcse_array("SERVER") : perl_print_gpcse_array("ENV",)),
|
||||
print_table_end();
|
||||
}
|
||||
|
||||
sub print_config {
|
||||
|
||||
return join '', print_section("Perl Core"),
|
||||
print_table_start(),
|
||||
print_table_header(2, "Variable", "Value"),
|
||||
print_config_sh($_[0]),
|
||||
print_table_end();
|
||||
}
|
||||
|
||||
sub print_config_sh {
|
||||
|
||||
my @configs = qw/api_versionstring cc ccflags cf_by cf_email cf_time extensions installarchlib installbin installhtmldir installhtmlhelpdir installprefix installprefixexp installprivlib installscript installsitearch installsitebin known_extensions libc libperl libpth libs myarchname optimize osname osvers package perllibs perlpath pm_apiversion prefix prefixexp privlib privlibexp startperl version version_patchlevel_string xs_apiversion/;
|
||||
|
||||
return ($_[0] eq 'info_all') ?
|
||||
join '', map { print_table_row(2, add_link('config',$_), $Config{$_})} @configs
|
||||
: join '', map { print_table_row(2, map{
|
||||
if ($_ !~ /^'/) {
|
||||
add_link('config', $_);
|
||||
}
|
||||
else {
|
||||
if ($_ eq "\'\'" || $_ eq "\' \'" ) {
|
||||
my $value = "<i>no value</i>";
|
||||
$value;
|
||||
}
|
||||
else {
|
||||
$_;
|
||||
}
|
||||
}
|
||||
}split/=/,$_ )
|
||||
} split /\n/, config_sh();
|
||||
}
|
||||
|
||||
sub print_httpd {
|
||||
|
||||
return unless (defined $ENV{'SERVER_SOFTWARE'} && $ENV{'SERVER_SOFTWARE'} =~ /apache/i);
|
||||
my $a = HTML::Perlinfo::Apache->new();
|
||||
|
||||
my $html .= print_section("Apache");
|
||||
$html .= print_table_start();
|
||||
$html .= $a->print_apache() if $a->has qw(env);
|
||||
$html .= print_table_end();
|
||||
|
||||
$html .= $a->print_modperl() if $a->has qw(mp);
|
||||
|
||||
$html .= print_section("Apache Environment"),
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(2, "Variable", "Value"),
|
||||
$html .= $a->print_apache_environment() if $a->has qw(env);
|
||||
$html .= print_table_end();
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub print_thesemodules {
|
||||
my $opt = shift;
|
||||
$m = HTML::Perlinfo::Modules->new();
|
||||
if ($opt eq 'core') {
|
||||
return $m->print_modules(show_only=>$opt, full_page=>0);
|
||||
}
|
||||
elsif ($opt eq 'all') {
|
||||
return $m->print_modules(section=>'All Perl modules', full_page=>0);
|
||||
}
|
||||
elsif ($opt eq 'loaded' && ref $_[0] eq 'ARRAY') {
|
||||
return $m->print_modules(section=>'Loaded Modules', files_in=>shift, full_page=>0);
|
||||
}
|
||||
else {
|
||||
die "internal function print_thesemodules has invalid arguments: @_";
|
||||
}
|
||||
}
|
||||
|
||||
sub print_general {
|
||||
|
||||
my $opt = shift || 'full';
|
||||
|
||||
my $html = print_box_start(1);
|
||||
$html .= sprintf("<h1 class=\"p\">Perl Version %s</h1><br style=\"clear:both\" />Release date: %s", perl_version(), release_date());
|
||||
|
||||
$html .= print_box_end();
|
||||
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_row(2, "Currently running on", "@{[ (uname)[0..4] ]}");
|
||||
$html .= print_table_row(2, "Built for", "$Config{archname}");
|
||||
$html .= print_table_row(2, "Build date", "$Config{cf_time}");
|
||||
$html .= print_table_row(2, "Perl path", "$^X");
|
||||
|
||||
$html .= print_table_row(2, "Additional C Compiler Flags", "$Config{ccflags}");
|
||||
$html .= print_table_row(2, "Optimizer/Debugger Flags", "$Config{optimize}");
|
||||
|
||||
if (defined($ENV{'SERVER_SOFTWARE'})) {
|
||||
$html .= print_table_row(2, "Server API", "$ENV{'SERVER_SOFTWARE'}");
|
||||
}
|
||||
if ($Config{usethreads} && !$Config{useithreads} && !$Config{use5005threads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (threads)");
|
||||
}
|
||||
elsif ($Config{useithreads} && !$Config{usethreads} && !$Config{use5005threads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (ithreads)");
|
||||
}
|
||||
elsif ($Config{use5005threads} && !$Config{usethreads} && !$Config{useithreads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (5005threads)");
|
||||
}
|
||||
elsif ($Config{usethreads} && $Config{useithreads} && !$Config{use5005threads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (threads, ithreads)");
|
||||
}
|
||||
elsif ($Config{usethreads} && $Config{use5005threads} && !$Config{useithreads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (threads, 5005threads)");
|
||||
}
|
||||
elsif ($Config{useithreads} && $Config{use5005threads} && !$Config{usethreads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (ithreads, 5005threads)");
|
||||
}
|
||||
elsif ($Config{usethreads} && $Config{useithreads} && $Config{use5005threads}) {
|
||||
$html .= print_table_row(2, "Thread Support", "enabled (threads, ithreads, 5005threads)");
|
||||
}
|
||||
else {
|
||||
$html .= print_table_row(2, "Thread Support", "disabled (threads, ithreads, 5005threads)");
|
||||
}
|
||||
$html .= print_table_end();
|
||||
|
||||
$html .= print_box_start(0);
|
||||
|
||||
|
||||
$html .= "This is perl, v$Config{version} built for $Config{archname}<br />Copyright (c) 1987-@{[ sprintf '%d', (localtime)[5]+1900]}, Larry Wall";
|
||||
$html .= print_box_end();
|
||||
|
||||
return $html if $opt eq 'top';
|
||||
|
||||
$html .= print_hr();
|
||||
$html .= "<h1>Configuration</h1>\n";
|
||||
$html .= print_config('info_all');
|
||||
|
||||
$html .= join '', print_section("Perl utilities"),
|
||||
print_table_start(),
|
||||
print_table_header(2, "Name", "Location"),
|
||||
print_table_row(2, add_link('cpan', 'h2ph'), check_path("h2ph")),
|
||||
print_table_row(2, add_link('cpan', 'h2xs'), check_path("h2xs")),
|
||||
print_table_row(2, add_link('cpan', 'perldoc'), check_path("perldoc")),
|
||||
print_table_row(2, add_link('cpan', 'pod2html'), check_path("pod2html")),
|
||||
print_table_row(2, add_link('cpan', 'pod2latex'), check_path("pod2latex")),
|
||||
print_table_row(2, add_link('cpan', 'pod2man'), check_path("pod2man")),
|
||||
print_table_row(2, add_link('cpan', 'pod2text'), check_path("pod2text")),
|
||||
print_table_row(2, add_link('cpan', 'pod2usage'), check_path("pod2usage")),
|
||||
print_table_row(2, add_link('cpan', 'podchecker'), check_path("podchecker")),
|
||||
print_table_row(2, add_link('cpan', 'podselect'), check_path("podselect")),
|
||||
print_table_end(),
|
||||
|
||||
print_section("Mail"),
|
||||
print_table_start(),
|
||||
print_table_row(2, 'SMTP', hostname()),
|
||||
print_table_row(2, 'sendmail_path', check_path("sendmail")),
|
||||
print_table_end(),
|
||||
|
||||
print_httpd(),
|
||||
|
||||
print_section("HTTP Headers Information"),
|
||||
print_table_start(),
|
||||
print_table_colspan_header(2, "HTTP Request Headers");
|
||||
if (defined($ENV{'SERVER_SOFTWARE'})) {
|
||||
$html .= join '',
|
||||
print_table_row(2, 'HTTP Request', "$ENV{'REQUEST_METHOD'} @{[File::Spec->abs2rel($0)]} $ENV{'SERVER_PROTOCOL'}"),
|
||||
print_table_row(2, 'Host', $ENV{'HTTP_HOST'}),
|
||||
print_table_row(2, 'User-Agent', $ENV{'HTTP_USER_AGENT'}),
|
||||
print_table_row(2, 'Accept', $ENV{'HTTP_ACCEPT_ENCODING'}),
|
||||
print_table_row(2, 'Accept-Language', $ENV{'HTTP_ACCEPT_LANGUAGE'}),
|
||||
print_table_row(2, 'Accept-Charset', $ENV{'HTTP_ACCEPT_CHARSET'}),
|
||||
print_table_row(2, 'Keep-Alive', $ENV{'HTTP_KEEP_ALIVE'}),
|
||||
print_table_row(2, 'Connection', $ENV{'HTTP_CONNECTION'});
|
||||
}
|
||||
$html .= print_table_end();
|
||||
return $html;
|
||||
}
|
||||
1;
|
||||
|
||||
147
database/perl/lib/HTML/Perlinfo/HTML.pod
Normal file
147
database/perl/lib/HTML/Perlinfo/HTML.pod
Normal file
@@ -0,0 +1,147 @@
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTML::Perlinfo::HTML - HTML documentation for the perlinfo library
|
||||
|
||||
=head1 SUMMARY
|
||||
|
||||
HTML::Perlinfo validates as XHTML 1.0 Transitional.
|
||||
|
||||
In the perlinfo library, L<HTML::Perlinfo> and L<HTML::Perlinfo::Modules> use the internal module HTML::Perlinfo::Common for HTML generation. This document provides information on that HTML and its manipulation.
|
||||
|
||||
=head1 CUSTOMIZING THE HTML
|
||||
|
||||
You can capture the HTML output by assigning it to a scalar. Then you can alter the HTML before printing it or doing something else with it. Here is an example that uses the perlinfo function from L<HTML::Perlinfo>:
|
||||
|
||||
use HTML::Perlinfo;
|
||||
|
||||
my $example = perlinfo(); # Now I can do whatever I want with $example
|
||||
$example =~ s/Perl/Java/ig; # Make everyone laugh
|
||||
print $example;
|
||||
|
||||
Another option is to use object attributes which make altering some HTML elements less helter skelter.
|
||||
|
||||
=head1 OBJECT ATTRIBUTES
|
||||
|
||||
These object attributes allow you to change the HTML CSS settings to achieve a stylish effect. Please see your favorite HTML guide for acceptable CSS values. Refer to the HTML source code of the perlinfo page for the defaults.
|
||||
|
||||
Attribute name/Corresponding CSS element
|
||||
|
||||
title / page title (only non-CSS element)
|
||||
bg_image / background_image
|
||||
bg_position / background_position
|
||||
bg_repeat / background_repeat
|
||||
bg_attribute / background_attribute
|
||||
bg_color / background_color
|
||||
ft_family / font_familty
|
||||
ft_color / font_color
|
||||
lk_color / link color
|
||||
lk_decoration / link text-decoration
|
||||
lk_bgcolor / link background-color
|
||||
lk_hvdecoration / link hover text-decoration
|
||||
header_bgcolor / table header background-color
|
||||
header_ftcolor / table header font color
|
||||
leftcol_bgcolor / background-color of leftmost table cell
|
||||
leftcol_ftcolor / font color of left table cell
|
||||
rightcol_bgcolor / background-color of right table cell
|
||||
rightcol_ftcolor / font color of right table cell
|
||||
|
||||
=head2 CSS EXAMPLE
|
||||
|
||||
$p = HTML::Perlinfo->new(
|
||||
bg_image => 'http://i104.photobucket.com/albums/m176/perlinfo/camel.gif',
|
||||
bg_repeat => 'yes-repeat'
|
||||
);
|
||||
$p->info_all;
|
||||
|
||||
=head1 print_htmlhead
|
||||
|
||||
This method prints the head container tags containing the style sheet, along with a few other html tags. It is useful to call this method when full_page is set to 0 and you are piecing together multiple perlinfo pages into one page. For example:
|
||||
|
||||
$m = HTML::Perlinfo::Modules->new( full_page => 0 ); # Just the bare essentials please
|
||||
|
||||
$m->print_htmlhead; # Print the beginning of an html document
|
||||
|
||||
$m->print_modules( from =>'/home/paco',
|
||||
section => 'The Modules in Paco's Home Directory'
|
||||
);
|
||||
|
||||
$m->print_modules( from =>'/home/cowboy',
|
||||
section => 'The Modules in Cowboy's Home Directory'
|
||||
);
|
||||
|
||||
When full_page is set to 1 (the default value), print_htmlhead is called internally. Note that you can still set CSS values in the constructor even when full_page is set to 0 and see the results in print_htmlhead.
|
||||
|
||||
$m = HTML::Perlinfo::Modules->new(
|
||||
full_page => 0,
|
||||
bg_color => 'gray'
|
||||
);
|
||||
|
||||
$m->print_htmlhead; # Prints a HTML document with a gray background
|
||||
|
||||
Of course, you don't have to use the print_htmlhead method. You could insert your own HTML with your own style sheet when you set full_page to 0.
|
||||
|
||||
=head1 full_page
|
||||
|
||||
Do you want only a fragment of HTML and not a page with body tags (among other things)? Then the full_page option is what you need to use (or a regular expression, as explained above). This option allows you to add your own header/footer if you so desire. By default, the value is 1. Set it to 0 to output the HTML report with as little HTML as possible.
|
||||
|
||||
$p = HTML::Perlinfo->new( full_page => 0 ); # Change value to 1 to get a full HTML page
|
||||
|
||||
=head1 links
|
||||
|
||||
By default, there will be useful links in most of the presented HTML in the perlinfo library. These links are for pages on search.cpan.org. Even the info_config method lists links to the config options in the core Config module.
|
||||
|
||||
To manipulate links in the perlinfo library, you can use the links attribute in the info methods. Not to be confused with the "link" attribute in the HTML::Perlinfo::Module (which allows you to provide your own links for modules), this attribute's primary purpose is to turn on linking or turn it off. Of course, you can achieve the same effect by using regular expressions, as explained above. But using the links attribute makes your code cleaner.
|
||||
|
||||
There are several arguments (in an array reference) you can supply to the links attribute.
|
||||
|
||||
The number 1 turns on all default links and 0 will remove them.
|
||||
|
||||
For example, to remove the default links in the info_all method, you would say:
|
||||
|
||||
$p->info_all( links=>[0] ); # contains no links. Good for printing!
|
||||
|
||||
The example above removes all default links and it even ignores the L<link|HTML::Perlinfo::Modules#link> parameter in the print_modules method of L<HTML::Perlinfo::Modules>.
|
||||
|
||||
The named parameters for the links attribute are 'docs' and 'local' which controls links associated with modules, programs in the Perl utilities section, and the Config section and everywhere else. The value for either parameter can be either '1' or '0'.
|
||||
|
||||
=over
|
||||
|
||||
=item docs
|
||||
|
||||
Using 'docs', you can control the display of the default links to module and program documentation on search.cpan.org. But the link parameter in L<HTML::Perlinfo::Modules> can override this directive. By overridding 'docs=>0', you can show documentation for certain modules and not show documentation for any others. This is useful, for example, when you have homegrown modules without any documentation but want to show links to documentation for CPAN modules on the same page. Observe:
|
||||
|
||||
$p->print_modules( links => [docs=>0], link => [qr/Apache::/, 'http://www.myexample.com/perldoc/'] );
|
||||
|
||||
In the above example, only links to Apache modules would appear. Other modules would not have links to any documentation. Note that had you simply set the value for links to zero, then the other attribute concerning Apache modules would have been irrelevant, since no links whatsoever would have appeared. In other words, you can mix and match these two atttibutes to achieve many different and wonderous effects. Have fun! Be imaginative!
|
||||
|
||||
For more information on print_modules and its link parameter, please see L<HTML::Perlinfo::Modules>.
|
||||
|
||||
=item local
|
||||
|
||||
With the 'local' parameter set to 1, the local location of a module or program will be a link. This is useful if you want to see the local installation directory of a module in your browser. (From there, you could also look at the contents of said files.)
|
||||
|
||||
Note that this link would only work if you use the perlinfo library from the command-line and then view the resulting page on the same machine. Hence these local links are not present by default.
|
||||
|
||||
You can even use 'docs' along with 'local'.
|
||||
|
||||
$p->info_all( links => [docs=>0,local=>1] )
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
L<HTML::Perlinfo::Modules> allows you to color code specific modules.
|
||||
|
||||
More HTML options should be available in future revisions. Want to see a new feature/change? Then contact me about it.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mike Accardo <mikeaccardo@yahoo.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2009, Mike Accardo. All Rights Reserved.
|
||||
|
||||
=cut
|
||||
66
database/perl/lib/HTML/Perlinfo/Loaded.pm
Normal file
66
database/perl/lib/HTML/Perlinfo/Loaded.pm
Normal file
@@ -0,0 +1,66 @@
|
||||
package HTML::Perlinfo::Loaded;
|
||||
BEGIN { %Seen = %INC }
|
||||
|
||||
use HTML::Perlinfo::Modules;
|
||||
|
||||
$VERSION = '1.02';
|
||||
|
||||
%INC = %Seen;
|
||||
END {
|
||||
|
||||
delete $INC{'HTML/Perlinfo/Loaded.pm'};
|
||||
my $m = HTML::Perlinfo::Modules->new(full_page=>0, title=>'perlinfo(INFO_LOADED)');
|
||||
$m->print_htmlhead;
|
||||
$m->print_modules('files_in'=>[values %INC],'section'=>'Loaded Modules');
|
||||
print $m->info_variables,"</div></body></html>";
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTML::Perlinfo::Loaded - Post-execution HTML dump of loaded modules and environment variables
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
#!/usr/bin/perl
|
||||
use HTML::Perlinfo::Loaded;
|
||||
...
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module installs an at-exit handler to generate an HTML dump of all the module files used by a Perl program. As an added bonus, environment variables are also included in this dump. When used under mod_perl, the module will show you preloaded modules in the HTML page too.
|
||||
|
||||
Since the "dump" is a complete HTML page, this module is a good debugging tool for Web applications. Just make sure you print the content-type header beforehand or you will get an internal server error (malformed header).
|
||||
|
||||
Note that the HTML::Perlinfo function 'perlinfo' has an option called INFO_LOADED that will produce the same result. In other words, there is more than one way to do it! Observe:
|
||||
|
||||
use HTML::Perlinfo;
|
||||
|
||||
perlinfo(INFO_LOADED);
|
||||
|
||||
The result will be the same if you say:
|
||||
|
||||
#!/usr/bin/perl
|
||||
use HTML::Perlinfo::Loaded;
|
||||
...
|
||||
|
||||
There is no difference, except using the perlinfo option gives you greater control. You could always control HTML::Perlinfo::Loaded with a pound sign (a comment on/off), but if you are using mod_perl it makes more sense to add HTML::Perlinfo to your startup file and then call perlinfo(INFO_LOADED) when you want to dump.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Devel::Loaded>, L<HTML::Perlinfo::Modules>, L<HTML::Perlinfo>, L<perlinfo>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mike Accardo <mikeaccardo@yahoo.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2008, Mike Accardo. All Rights Reserved.
|
||||
This module is free software. It may be used, redistributed
|
||||
and/or modified under the terms of the Perl Artistic License.
|
||||
|
||||
=cut
|
||||
753
database/perl/lib/HTML/Perlinfo/Modules.pm
Normal file
753
database/perl/lib/HTML/Perlinfo/Modules.pm
Normal file
@@ -0,0 +1,753 @@
|
||||
package HTML::Perlinfo::Modules;
|
||||
|
||||
use strict;
|
||||
use File::Find;
|
||||
use File::Spec;
|
||||
use Carp ();
|
||||
use Config qw(%Config);
|
||||
use base qw(HTML::Perlinfo::Base);
|
||||
use CGI qw(escapeHTML);
|
||||
use HTML::Perlinfo::Common;
|
||||
|
||||
our $VERSION = '1.17';
|
||||
|
||||
|
||||
sub new {
|
||||
|
||||
my ($class, %params) = @_;
|
||||
$params{'title'} = exists $params{'title'} ? $params{'title'} : 'Perl Modules';
|
||||
|
||||
$class->SUPER::new(%params);
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub module_color_check {
|
||||
|
||||
my ($module_name, $color_specs) = @_;
|
||||
if (defined $color_specs && ref($color_specs->[0]) eq 'ARRAY') {
|
||||
foreach (@{ $color_specs }) {
|
||||
return $_->[0] if (match_string($module_name,$_->[1])==1);
|
||||
}
|
||||
}
|
||||
else {
|
||||
return $color_specs->[0] if (defined $color_specs && match_string($module_name,$color_specs->[1])==1);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
# get_modinfo
|
||||
# This sub was created for the files_in option.
|
||||
# Returns found_mod reference
|
||||
######################################
|
||||
|
||||
sub get_files_in {
|
||||
|
||||
my ($file_path) = @_;
|
||||
|
||||
return 0 unless $file_path =~ m/\.pm$/;
|
||||
my $mod_info = module_info($file_path, undef);
|
||||
return $mod_info;
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub sort_modules {
|
||||
|
||||
my ($modules, $sort_by) = @_;
|
||||
my @sorted_modules;
|
||||
|
||||
if ($sort_by eq 'name') {
|
||||
foreach my $key (sort {lc $a cmp lc $b} keys %$modules) {
|
||||
# Check for duplicate modules
|
||||
if (ref($modules->{$key}) eq 'ARRAY') {
|
||||
foreach (@{ $modules->{$key} }) {
|
||||
push @sorted_modules, $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @sorted_modules, $modules->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($sort_by eq 'version') {
|
||||
foreach my $key (keys %$modules) {
|
||||
if (ref($modules->{$key}) eq 'ARRAY') {
|
||||
@{ $modules->{$key} } = sort {$a->{'version'} cmp $b->{'version'}}@{ $modules->{$key} };
|
||||
for (@{ $modules->{$key}}) {
|
||||
push @sorted_modules, $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @sorted_modules, $modules->{$key};
|
||||
}
|
||||
}
|
||||
@sorted_modules = sort {$a->{'version'} cmp $b->{'version'}}@sorted_modules;
|
||||
}
|
||||
return @sorted_modules;
|
||||
}
|
||||
|
||||
sub html_setup {
|
||||
|
||||
my ($self, $columns, $color_specs, $section, $full_page) = @_;
|
||||
|
||||
my $html;
|
||||
|
||||
$html .= $self->print_htmlhead if $full_page;
|
||||
|
||||
my %show_columns = (
|
||||
'name' => 'Module name',
|
||||
'version' => 'Version',
|
||||
'path' => 'Location',
|
||||
'core' => 'Core',
|
||||
'desc' => 'Description'
|
||||
);
|
||||
|
||||
$html .= $section ? print_section($section) : '';
|
||||
$html .= print_color_codes($color_specs) if $color_specs && $color_specs->[2];
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(scalar @$columns, map{ $show_columns{$_} }@$columns);
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub module_info {
|
||||
my ($module_path, $show_only) = @_;
|
||||
|
||||
( $module_path ) = $module_path =~ /^(.*)$/;
|
||||
|
||||
my ($mod_name, $mod_version, $mod_desc);
|
||||
|
||||
no warnings 'all'; # silence warnings
|
||||
open(MOD, $module_path) or return 0;
|
||||
while (<MOD>) {
|
||||
|
||||
unless ($mod_name) {
|
||||
if (/^ *package +(\S+);/) {
|
||||
$mod_name = $1;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($mod_version) {
|
||||
|
||||
if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
|
||||
|
||||
my $line = substr $_, index($_, $1);
|
||||
my $eval = qq{
|
||||
package HTML::Perlinfo::_version;
|
||||
no strict;
|
||||
|
||||
local $1$2;
|
||||
\$$2=undef; do {
|
||||
$line
|
||||
}; \$$2
|
||||
};
|
||||
|
||||
( $eval ) = $eval =~ /^(.*)$/sm;
|
||||
$mod_version = eval($eval);
|
||||
# Again let us be nice here.
|
||||
$mod_version = '<i>unknown</i>' if (not defined $mod_version) || ($@);
|
||||
$mod_version =~ s/^\s+|\s+$//;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($mod_desc) {
|
||||
if (/=head\d\s+NAME/) {
|
||||
local $/ = '';
|
||||
local $_;
|
||||
chomp($_ = <MOD>);
|
||||
($mod_desc) = /^.*?-+\s*(.*?)$/ism;
|
||||
}
|
||||
}
|
||||
|
||||
last if $mod_name && $mod_version && $mod_desc;
|
||||
|
||||
}
|
||||
|
||||
close (MOD);
|
||||
return 0 if (! $mod_name || $show_only && ref $show_only && (match_string($mod_name, $show_only) == 0));
|
||||
$mod_version = '<i>unknown</i>' if !($mod_version) || ($mod_version !~ /^[\.\d+_]+$/);
|
||||
$mod_desc = escapeHTML($mod_desc) if $mod_desc;
|
||||
$mod_desc = "<i>No description found</i>" unless $mod_desc;
|
||||
return { 'name' => $mod_name, 'version' => $mod_version, 'desc' => $mod_desc };
|
||||
}
|
||||
|
||||
sub print_color_codes {
|
||||
my $color_specs = shift;
|
||||
my ($html, $label);
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(1, "Module Color Codes");
|
||||
$html .= print_table_color_start();
|
||||
|
||||
if (ref($color_specs->[0]) eq 'ARRAY') {
|
||||
my $count = 0;
|
||||
foreach (@{ $color_specs }) {
|
||||
$html .= "<tr>" if $count++ % 5 == 0;
|
||||
$label = $_->[2] || $_->[1];
|
||||
$html .= print_color_box($_->[0], $label);
|
||||
$html .= "</tr>" if (($count >= 5 && $count % 5 == 0)||($count >= @{$color_specs}));
|
||||
}
|
||||
}
|
||||
else {
|
||||
$label = $color_specs->[2] || $color_specs->[1];
|
||||
$html .= print_color_box($color_specs->[0], $label);
|
||||
}
|
||||
|
||||
$html .= print_table_color_end();
|
||||
$html .= print_table_end();
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub print_module_results {
|
||||
|
||||
my ($mod_dir, $mod_count, $from, $overall_total, $show_dir) = @_;
|
||||
|
||||
my ($html, $total_amount, $searched, @mod_dir, @bad_dir, %seen);
|
||||
|
||||
if ($show_dir) {
|
||||
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(2, "Directory", "Number of Modules");
|
||||
for my $dir (keys %{$mod_count}) {
|
||||
my $amount_found = $mod_count->{$dir};
|
||||
push (@mod_dir, $dir) if $amount_found;
|
||||
}
|
||||
|
||||
for my $dir1 (@mod_dir) {
|
||||
for my $dir2 (@mod_dir) {
|
||||
if ($dir1 ne $dir2 && $dir2 =~ /^$dir1/) {
|
||||
push @bad_dir, $dir2;
|
||||
}
|
||||
}
|
||||
}
|
||||
for my $top_dir (@mod_dir) {
|
||||
unless (grep{$_ eq $top_dir }@bad_dir) {
|
||||
$html .= print_table_row(2, add_link('local', File::Spec->canonpath($top_dir)), $mod_count->{$top_dir});
|
||||
}
|
||||
}
|
||||
$html .= print_table_end();
|
||||
}
|
||||
else {
|
||||
# Print out directories not in @INC
|
||||
@mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@INC;
|
||||
my @module_paths = grep { not exists $seen{$_} }@$mod_dir;
|
||||
|
||||
if (@module_paths >= 1) {
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(3, "Directory", "Searched", "Number of Modules");
|
||||
|
||||
for my $dir (map{ File::Spec->canonpath($_) }@module_paths) {
|
||||
$searched = (grep { $_ eq $dir } @$mod_dir) ? "yes" : "no";
|
||||
my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : '<i>unknown</i>';
|
||||
$html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
|
||||
}
|
||||
$html .= print_table_end();
|
||||
}
|
||||
|
||||
|
||||
$html .= print_table_start();
|
||||
$html .= print_table_header(3, "Include path (INC) directories", "Searched", "Number of Modules");
|
||||
for my $dir (@mod_dir) {
|
||||
$searched = exists $mod_count->{$dir} ? 'yes' : 'no';
|
||||
my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : '<i>unknown</i>';
|
||||
$html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
|
||||
}
|
||||
|
||||
$html .= print_table_end();
|
||||
}
|
||||
|
||||
$html .= print_table_start();
|
||||
#my $view = ($from eq 'all') ? 'installed' :
|
||||
# ($from eq 'core') ? 'core' : 'found';
|
||||
|
||||
$html .= print_table_row(2, "Total modules", $overall_total);
|
||||
$html .= print_table_end();
|
||||
|
||||
return $html;
|
||||
|
||||
}
|
||||
|
||||
sub search_dir {
|
||||
|
||||
my ($from, $show_only, $core_dir1, $core_dir2) = @_;
|
||||
|
||||
|
||||
my %seen = ();
|
||||
|
||||
my @user_dir = (ref($from) eq 'ARRAY') && $show_only ne 'core' ? @{$from} :
|
||||
($show_only eq 'core') ? ($core_dir1, $core_dir2) : $from;
|
||||
|
||||
# Make sure only unique entries and readable directories in @mod_dir
|
||||
my @mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
|
||||
if (@mod_dir != @user_dir) {
|
||||
|
||||
# Looks like there might have been a problem with the directories given to us.
|
||||
# Or maybe not. @user_dir could have duplicate values and that's ok.
|
||||
# But let's still warn about any unreadable or non-directories given
|
||||
|
||||
my @debug;
|
||||
%seen = ();
|
||||
@user_dir = grep { !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
|
||||
if (@user_dir > @mod_dir) {
|
||||
#%seen = map {$_ => undef} @mod_dir;
|
||||
%seen = ();
|
||||
@seen{@mod_dir} = ();
|
||||
my @difference = grep { !$seen{$_}++ }@user_dir;
|
||||
foreach my $element (@difference) {
|
||||
if (! -d $element) {
|
||||
if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
|
||||
warn "$element is in the Perl include path, but is not a directory";
|
||||
}
|
||||
else {
|
||||
warn "$element is not a directory";
|
||||
}
|
||||
push @debug, $element;
|
||||
}
|
||||
elsif (! -r $element) {
|
||||
if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
|
||||
warn "$element is in the Perl include path, but is not readable";
|
||||
}
|
||||
else {
|
||||
warn "$element is not a readable directory";
|
||||
}
|
||||
|
||||
push @debug, $element;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
error_msg("Search directories are invalid") unless @mod_dir >= 1;
|
||||
|
||||
return @mod_dir;
|
||||
}
|
||||
|
||||
sub get_input {
|
||||
|
||||
my $self = shift;
|
||||
my $args = process_args(@_, \&check_module_args);
|
||||
my %input = ();
|
||||
$input{'files_in'} = $args->{'files_in'} || undef;
|
||||
$input{'sort_by'} = $args->{'sort_by'} || 'name';
|
||||
$input{'from'} = $args->{'from'} || \@INC;
|
||||
$input{'show_only'} = $args->{'show_only'} || "";
|
||||
$input{'color_specs'} = $args->{'color'};
|
||||
$input{'link'} = $args->{'link'};
|
||||
$input{'section'} = exists $args->{'section'} ? $args->{'section'} :
|
||||
$input{'show_only'} eq 'core' ? 'Core Perl modules installed' : '';
|
||||
$input{'full_page'} = exists $args->{'full_page'} ? $args->{'full_page'} : $self->{'full_page'};
|
||||
$input{'show_inc'} = exists $args->{'show_inc'} ? $args->{'show_inc'} : 1;
|
||||
$input{'show_dir'} = exists $args->{'show_dir'} ? $args->{'show_dir'} : 0;
|
||||
$input{'columns'} = exists $args->{'columns'} ? $args->{'columns'} : ['name','version','desc'];
|
||||
return %input;
|
||||
}
|
||||
|
||||
sub print_modules {
|
||||
|
||||
my %input = get_input(@_);
|
||||
|
||||
my ($found_mod, $mod_count, $overall_total, @mod_dir, $core_dir1, $core_dir2);
|
||||
|
||||
# Check to see if a search is even needed
|
||||
if (defined $input{'files_in'}) {
|
||||
|
||||
my @files = @{ $input{'files_in'} };
|
||||
my %found_mod = ();
|
||||
|
||||
foreach my $file_path (@files) {
|
||||
|
||||
my $mod_info = get_files_in($file_path);
|
||||
next unless (ref $mod_info eq 'HASH');
|
||||
$found_mod{$mod_info->{'name'}} = $mod_info;
|
||||
}
|
||||
return undef unless (keys %found_mod > 0);
|
||||
$found_mod = \%found_mod;
|
||||
}
|
||||
else {
|
||||
|
||||
# Get ready to search
|
||||
$core_dir1 = File::Spec->canonpath($Config{installarchlib});
|
||||
$core_dir2 = File::Spec->canonpath($Config{installprivlib});
|
||||
|
||||
@mod_dir = search_dir($input{'from'}, $input{'show_only'}, $core_dir1, $core_dir2);
|
||||
|
||||
($overall_total, $found_mod, $mod_count) = find_modules($input{'show_only'}, \@mod_dir);
|
||||
|
||||
return undef unless $overall_total;
|
||||
|
||||
}
|
||||
|
||||
my @sorted_modules = sort_modules($found_mod, $input{'sort_by'});
|
||||
|
||||
my $html .= html_setup( $_[0],
|
||||
$input{'columns'},
|
||||
$input{'color_specs'},
|
||||
$input{'section'},
|
||||
$input{'full_page'}
|
||||
);
|
||||
|
||||
my $numberof_columns = scalar @{$input{'columns'}};
|
||||
|
||||
foreach my $module (@sorted_modules) {
|
||||
|
||||
$html .= print_table_row_color( $numberof_columns,
|
||||
module_color_check($module->{'name'}, $input{'color_specs'}),
|
||||
map{
|
||||
if ($_ eq 'name') {
|
||||
add_link('cpan', $module->{'name'}, $input{'link'});
|
||||
}
|
||||
elsif ($_ eq 'core') {
|
||||
(grep File::Spec->rel2abs($module->{'path'}) =~ /\Q$_/, ($core_dir1, $core_dir2)) ? 'yes' : 'no';
|
||||
}
|
||||
elsif ($_ eq 'path') {
|
||||
add_link('local', $module->{'path'});
|
||||
}
|
||||
else {
|
||||
$module->{$_};
|
||||
}
|
||||
|
||||
} @{$input{'columns'}} );
|
||||
}
|
||||
|
||||
$html .= print_table_end();
|
||||
|
||||
unless (defined $input{'files_in'} && ref $input{'files_in'} eq 'ARRAY') {
|
||||
$html .= print_module_results( \@mod_dir,
|
||||
$mod_count,
|
||||
$input{'from'},
|
||||
$overall_total,
|
||||
$input{'show_dir'}) if $input{'show_inc'};
|
||||
}
|
||||
|
||||
$html .= "</div></body></html>" if $input{'full_page'};
|
||||
|
||||
defined wantarray ? return $html : print $html;
|
||||
|
||||
}
|
||||
|
||||
sub find_modules {
|
||||
|
||||
my ($show_only, $mod_dir) = @_;
|
||||
|
||||
my ($overall_total, $module, $base, $start_dir, $new_val, $mod_info);
|
||||
# arrays
|
||||
my (@modinfo_array, @mod_dir);
|
||||
# hashes
|
||||
my ( %path, %inc_path, %mod_count, %found_mod);
|
||||
@mod_dir = @$mod_dir;
|
||||
|
||||
@path{@mod_dir} = ();
|
||||
@inc_path{@INC} = ();
|
||||
for $base (@mod_dir) {
|
||||
|
||||
find ({ wanted => sub {
|
||||
for (@INC, @mod_dir) {
|
||||
if (index($File::Find::name, $_) == 0) {
|
||||
# lets record it unless we already have hit the dir
|
||||
$mod_count{$_} = 0 unless exists $mod_count{$_};
|
||||
}
|
||||
}
|
||||
# This prevents mod_dir dirs from being searched again when you have a dir within a dir
|
||||
$File::Find::prune = 1, return if exists $path{$File::Find::name} && $File::Find::name ne $File::Find::topdir;
|
||||
|
||||
# make sure we are dealing with a module
|
||||
return unless $File::Find::name =~ m/\.pm$/;
|
||||
$mod_info = module_info($File::Find::name, $show_only);
|
||||
return unless ref ($mod_info) eq 'HASH';
|
||||
|
||||
# update the counts.
|
||||
for (@INC, grep{not exists $inc_path{$_}}@mod_dir) {
|
||||
if (index($File::Find::name, $_) == 0) {
|
||||
$mod_count{$_}++;
|
||||
}
|
||||
}
|
||||
$overall_total++;
|
||||
|
||||
$mod_info->{'path'} = File::Spec->canonpath($File::Find::dir);
|
||||
# Check for duplicate modules
|
||||
if (exists $found_mod{$mod_info->{'name'}}) {
|
||||
@modinfo_array = ref( $found_mod{$mod_info->{'name'}} ) eq 'ARRAY' ? @{$found_mod{$mod_info->{'name'}}} : $found_mod{$mod_info->{'name'}};
|
||||
push @modinfo_array, $mod_info;
|
||||
$new_val = [@modinfo_array];
|
||||
$found_mod{$mod_info->{'name'}} = $new_val;
|
||||
}
|
||||
else {
|
||||
$found_mod{$mod_info->{'name'}} = $mod_info;
|
||||
}
|
||||
|
||||
},untaint => 1, untaint_pattern => qr|^([-+@\s\S\w./]+)$|}, $base);
|
||||
} # end of for loop
|
||||
|
||||
return ($overall_total, \%found_mod, \%mod_count);
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTML::Perlinfo::Modules - Display a lot of module information in HTML format
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use HTML::Perlinfo::Modules;
|
||||
|
||||
my $m = HTML::Perlinfo::Modules->new();
|
||||
$m->print_modules;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module outputs information about your Perl modules in HTML. The information includes a module's name, version, description and location. The HTML presents the module information in B<two sections>, one section is a list of modules and the other is a summary of this list. Both the list and its summary are configurable.
|
||||
|
||||
Other information displayed:
|
||||
|
||||
- Duplicate modules. So if you have CGI.pm installed in different locations, these duplicate modules will be shown.
|
||||
|
||||
- Automatic links to module documentation on CPAN (you can also provide your own URLs).
|
||||
|
||||
- The number of modules under each directory.
|
||||
|
||||
You can chose to show 'core' modules or you can search for specific modules. You can also define search paths. HTML::Perlinfo::Modules searches the Perl include path (from @INC) by default. You can also highlight specific modules with different colors.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 print_modules
|
||||
|
||||
This is the key method in this module. It accepts optional named parameters that dictate the display of module information. The method returns undefined if no modules were found. This means that you can write code such as:
|
||||
|
||||
my $modules = $m->print_modules(from=>'/home/paco');
|
||||
|
||||
if ($modules) {
|
||||
print $modules;
|
||||
}
|
||||
else {
|
||||
print "No modules are in Paco's home directory!";
|
||||
}
|
||||
|
||||
The code example above will show you the modules in Paco's home directory if any are found. If none are found, the code prints the message in the else block. There is a lot more you can do with the named parameters, but you do not have to use them. For example:
|
||||
|
||||
$m->print_modules;
|
||||
|
||||
# The above line is the equivalent of saying:
|
||||
$m->print_modules(
|
||||
from => \@INC,
|
||||
columns => ['name','version','desc'],
|
||||
sort_by => 'name',
|
||||
show_inc => 1
|
||||
);
|
||||
|
||||
# Alternatively, in this case, you could use a HTML::Perlinfo method to achieve the same result.
|
||||
# Note that HTML::Perlinfo::Modules inherits all of the HTML::Perlinfo methods
|
||||
|
||||
$m->info_modules;
|
||||
|
||||
The optional named parameters for the print_modules method are listed below.
|
||||
|
||||
=head3 from
|
||||
|
||||
Show modules from specific directories.
|
||||
|
||||
This parameter accepts 2 things: a single directory or an array reference (containing directories).
|
||||
|
||||
The default value is the Perl include path. This is equivalent of supplying \@INC as a value. If you want to show all of the modules on your box, you can specify '/' as a value (or the disk drive on Windows).
|
||||
|
||||
=head3 files_in
|
||||
|
||||
If you don't need to search for your files and you already have the B<complete pathnames> to them, then you can use the 'files_in' option which accepts an array reference containing the files you wish to display. One obvious use for this option would be in displaying the contents of the INC hash, which holds the modules used by your Perl module or script:
|
||||
|
||||
$m->print_modules('files_in'=>[values %INC]);
|
||||
|
||||
This is the same technique used by the L<HTML::Perlinfo::Loaded> module which performs a post-execution HTML dump of your loaded modules. See L<HTML::Perlinfo::Loaded> for details.
|
||||
|
||||
=head3 columns
|
||||
|
||||
This parameter allows you to control the table columns in the list of modules. With this parameter, you can dictate which columns will be shown and their order. Examples:
|
||||
|
||||
# Show only module names
|
||||
columns=>['name']
|
||||
|
||||
# Show version numbers before names
|
||||
columns=>['version','name']
|
||||
|
||||
# Default columns are:
|
||||
columns=>['name','version','desc']
|
||||
|
||||
The column parameter accepts an array reference containing strings that represent the column names. Those names are:
|
||||
|
||||
=over
|
||||
|
||||
=item name
|
||||
|
||||
The module name. This value is the namespace in the package declaration. Note that the method for retrieving the module name is not fool proof, since a module file can have multiple package declarations. HTML::Perlinfo::Modules grabs the namespace from the first package declaration that it finds.
|
||||
|
||||
=item version
|
||||
|
||||
The version number. Divines the value of $VERSION.
|
||||
|
||||
=item desc
|
||||
|
||||
The module description. The description is from the POD. Note that some modules don't have POD (or have POD without a description) and, in such cases, the message "No description found" will be shown.
|
||||
|
||||
=item path
|
||||
|
||||
The full path to the module file on disk. Printing out the path is especially useful when you want to learn the locations of duplicate modules.
|
||||
|
||||
B<Note that you can make this path a link.> This is useful if you want to see the local installation directory of a module in your browser. (From there, you could also look at the contents of the files.) Be aware that this link would only work if you use this module from the command-line and then view the resulting page on the same machine. Hence these local links are not present by default. To learn more about local links, please refer to the L<HTML documentation|HTML::Perlinfo::HTML>.
|
||||
|
||||
=item core
|
||||
|
||||
This column value (either 'yes' or 'no') will tell you if the module is core. In other words, it will tell you if the module was included in your Perl distribution. If the value is 'yes', then the module lives in either the installarchlib or the installprivlib directory listed in the config file.
|
||||
|
||||
=back
|
||||
|
||||
=head3 sort_by
|
||||
|
||||
You use this parameter to sort the modules. Values can be either 'version' for version number sorting (in descending order) or 'name' for alphabetical sorting (the default).
|
||||
|
||||
=head3 show_only
|
||||
|
||||
This parameter acts like a filter and only shows you the modules (more specifically, the package names) you request. So if, for example, you wanted to only show modules in the Net namspace, you would use the show_only parameter. It is probably the most useful option available for the print_modules method. With this option, you can use HTML::Perlinfo::Modules as a search engine tool for your local Perl modules. Observe:
|
||||
|
||||
$m->print_modules(
|
||||
show_only => ['MYCOMPANY::'],
|
||||
section => 'My Company's Custom Perl Modules',
|
||||
show_dir => 1
|
||||
);
|
||||
|
||||
The example above will print out every module in the 'MYCOMPANY' namespace in the Perl include path (@INC). The list will be entitled 'My Company's Custom Perl Modules' and because show_dir is set to 1, the list will only show the directories in which these modules were found along with how many are present in each directory.
|
||||
|
||||
You can add namespaces to the array reference:
|
||||
|
||||
$m->print_modules(
|
||||
show_only => ['MYCOMPANY::', 'Apache::'],
|
||||
section => 'My Company's Custom Perl Modules & Apache Modules',
|
||||
show_dir => 1
|
||||
);
|
||||
|
||||
In addition to an array reference, show_only also accepts the word 'core', a value that will show you all of the core Perl modules (in the installarchlib and installprivlib directories from the config file).
|
||||
|
||||
=head3 show_inc
|
||||
|
||||
Whenever you perform a module search, you will see a summary of your search that includes the directories searched and the number of modules found. Whether or not your search encompasses the Perl include path (@INC), you will still see these directories, along with any other directories that were actually searched. If you do not what to see this search summary, you must set show_inc to 0. The default value is 1.
|
||||
|
||||
=head3 show_dir
|
||||
|
||||
The default value is 0. Setting this parameter to 1 will only show you the directories in which your modules were found (along with a summary of how many were found, etc). If you do not want to show a search summary, then you must use the show_inc parameter.
|
||||
|
||||
=head3 color
|
||||
|
||||
This parameter allows you to highlight modules with different colors. Highlighting specific modules is a good way to draw attention to them.
|
||||
|
||||
The parameter value must be an array reference containing at least 2 elements. The first element is the color itself which can be either a hex code like #FFD700 or the name of the color. The second element specifies the module(s) to color. And the third, optional element, in the array reference acts as a label in the color code section. This final element can even be a link if you so desire.
|
||||
|
||||
Examples:
|
||||
|
||||
color => ['red', 'Apache::'],
|
||||
color => ['#FFD700', 'CGI::']
|
||||
|
||||
Alternatively, you can also change the color of the rows, by setting CSS values in the constructor. For example:
|
||||
|
||||
$m = HTML::Perlinfo::Modules->new(
|
||||
leftcol_bgcolor => 'red',
|
||||
rightcol_bgcolor => 'red'
|
||||
);
|
||||
|
||||
$m->print_modules(
|
||||
show_only => 'CGI::',
|
||||
show_inc => 0
|
||||
);
|
||||
|
||||
# This next example does the same thing, but uses the color parameter in the print_modules method
|
||||
|
||||
$m = HTML::Perlinfo::Modules->new();
|
||||
|
||||
$m->print_modules(
|
||||
show_only => ['CGI::'],
|
||||
color => ['red', 'CGI::'],
|
||||
show_inc => 0
|
||||
);
|
||||
|
||||
The above example will yield the same HTML results. So which approach should you use? The CSS approach gives you greater control of the HTML presentation. The color parameter, on the other hand, only affects the row colors in the modules list. You cannot achieve that same effect using CSS. For example:
|
||||
|
||||
$m->print_modules( color => ['red', 'CGI::'], color => ['red', 'Apache::'] );
|
||||
|
||||
The above example will list B<all of the modules> in @INC with CGI modules colored red and Apache modules colored blue.
|
||||
|
||||
For further information on customizing the HTML, including setting CSS values, please refer to the L<HTML documentation|HTML::Perlinfo::HTML>.
|
||||
|
||||
=head3 section
|
||||
|
||||
The section parameter lets you put a heading above the module list. Example:
|
||||
|
||||
$m->print_modules(
|
||||
show_only => ['Apache::'],
|
||||
section => 'Apache/mod_perl modules',
|
||||
show_dir => 1,
|
||||
);
|
||||
|
||||
=head3 full_page
|
||||
|
||||
Do you want only a fragment of HTML and not a page with body tags (among other things)? Then the full_page option is what you need to use (or a regular expression, as explained in the L<HTML documentation|HTML::Perlinfo::HTML>). This option allows you to add your own header/footer if you so desire. By default, the value is 1. Set it to 0 to output the HTML report with as little HTML as possible.
|
||||
|
||||
$m = HTML::Perlinfo::Modules->new( full_page => 0 );
|
||||
# You will still get an HTML page but without CSS settings or body tags
|
||||
$m->print_modules;
|
||||
|
||||
$m->print_modules( full_page => 1 ); # Now you will get the complete, default HTML page.
|
||||
|
||||
Note that the full_page option can be set in either the constructor or the method call. The advantage of setting it in the constructor is that every subsequent method call will have this attribute. (There is no limit to how many times you can call print_modules in a program. If calling the method more than once makes no sense to you, then you need to look at the show_only and from options.) If you set the full_page in the print_modules method, you will override its value in the object.
|
||||
|
||||
=head3 link
|
||||
|
||||
By default, every module is linked to its documentation on search.cpan.org. However some modules, such as custom modules, would not be in CPAN and their link would not show any documentation. With the 'link' parameter you can override the CPAN link with you own URL.
|
||||
|
||||
The parameter value must be an array reference containing two elements. The first element can either be a string specifying the module(s) to link or an array reference containing strings or the word 'all' which will link all the modules in the list. The second element is the root URL. In the link, the module name will come after the URL. So in the example below, the link for the Apache::Status module would be 'http://www.myexample.com/perldoc/Apache::Status'.
|
||||
|
||||
link => ['Apache::', 'http://www.myexample.com/perldoc/']
|
||||
|
||||
# Another example
|
||||
my $module = HTML::Perlinfo::Modules
|
||||
->new
|
||||
->print_modules( show_only => ['CGI::','File::','HTML::'],
|
||||
link => ['HTML::', 'http://www.html-example.com/perldoc/'],
|
||||
link => [['CGI::','File::'], 'http://www.examples.com/perldoc/'] );
|
||||
|
||||
|
||||
Further information about linking is in the L<HTML documentation|HTML::Perlinfo::HTML>.
|
||||
|
||||
=head1 CUSTOMIZING THE HTML
|
||||
|
||||
HTML::Perlinfo::Modules uses the same HTML generation as its parent module, HTML::Perlinfo.
|
||||
|
||||
You can capture the HTML output and manipulate it or you can alter CSS elements with object attributes.
|
||||
|
||||
(Note that you can also highlight certain modules with the color parameter to print_modules.)
|
||||
|
||||
For further details and examples, please see the L<HTML documentation|HTML::Perlinfo::HTML> in the HTML::Perlinfo distribution.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to C<bug-html-perlinfo@rt.cpan.org>, or through the web interface at
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Perlinfo>.
|
||||
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
If you decide to use this module in a CGI script, make sure you print out the content-type header beforehand.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<HTML::Perlinfo::Loaded>, L<HTML::Perlinfo>, L<perlinfo>, L<Module::Info>, L<Module::CoreList>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Mike Accardo <mikeaccardo@yahoo.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2006-8, Mike Accardo. All Rights Reserved.
|
||||
This module is free software. It may be used, redistributed
|
||||
and/or modified under the terms of the Perl Artistic License.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user